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airead.me 


TEXT 

"AI in Computer Vision" John L. Cuadrado and Clara Y. Cuadrado. 

K,^ ar «’ page 237 * A,so down,oad frames.pro I ist ing2.pro, and iisting3.pro 
o2I E: . Run ? under Pdprolog.exe which can be found in the FromBYTE85 file area. 
PDProlog is an MS-DOS or PC-DOS program only. 


The prolog •jsfmg FRAMES.PRO will compile and run under PDPROLOG. The major 
limitation of PDPROLOG in this context is that it does not support 
floating-point arithmetic. We have truncated the value of pi in the 
cylinder cross-sectional area routine to 3. An alternative approach would 
be to use, e.g., 314 and mentally divide each area and volume by 100 to 
obtain an answer to two decimal points. In any case, when you enter values 
from the keyboard for, e.g., the Radius, you must use integer values if 
you are running PDPROLOG. y 


To invoke the program, boot PDPROLOG and type: 
consuIt(•frames'). 

After the program has compiled, type: 
frame_put(cylinderl,radius,2). 
frame_put(cylinder1,height,10). 
etc. 


In order to see the affect of entering a value for the radius or heiaht 
you may either type: y # 

Iisting(cylinderl). 

(Don * t forget the period at the end of commands). 

Or, you may use the frame_get predicate: 
frame_get(cylinderl,X,Y). 

X end Y must be capital letters. Initial cops indicate variable names in 
Pro Iog. 


To change values for cylinderl, you may use either 
frame_removefcyIinderl,radius). [or 

frame_remove(cylinder1,name-of-sIot-to-be-deIeted).] followed by 
frame.put(ENTER NEW VALUE AS EXPLAINED FOR FRAME.PUT ABOVE), 
or frame_replace(cylinderl.radius,4). or whatever value you want changed 
This form allows the new value to be entered in one step, but is otherwise 
equivalent to frame — remove folloed by frame_put. 


To end a pdprolog session and return to the operating system 
enter exitsys." (without the quotes, of course). 


I eve I, 


EXECUTED AN ° LISTING3,PR0 ARE N0T STAND-ALONE PROGRAMS. THEY CANNOT BE 


The current version of pdprolog, pdprolog 1.8 is included on this disk. 
PuI I documentation and other sample prolog programs are available for 
downloading from BYTEnet Listings (617)861-9764 or from BIX. 


PDPROLOG.EXE IS A PC-DOS OR MS-DOS PROGRAM ONLY. 


list!ng2.pro 
TEXT 

"AI in Computer Vision." See airead.me. 


window_type1 

ako 

value : window 

panes 

value : 12 

style 


value : sash 

window_type2 

ako 

value : window 

panes 

( continued ) 
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value 

style 

VOlLt 

wirdow_ty?«3 

cko 

va I ue 

panes 

va I ue 

style 

value 

window_type4 

ako 

va I ue 

panes 

va I ue 

sty I e 

va I ue 

window_type5 

ako 

va I ue 

panes 

va I ue 

style 

va I ue 


24 

sash 

window 

3 

picture 

window 

3 

sash 

window 

2 

sash 


window 

ako 

value : thing 

area 

If_needed : w!ndow_area 

window_area(Window,Area) 

fget(Window,height,Height), 
fget(Window.width.Width), 
Area is Height * Width, 
frep I ace(Window,area,Area). 


door_type1 

ako 

value : door 
pane Is 

value : 4 
symmetry 

value : yes 
doorway 

value : [coIumns,fan_light] 

door_type2 

ako 

value : door 
pane Is 

value : 6 
symmetry 

value : yes 
doorway 

value : [columns, portico, 
s i de__windows] 

door_type3 

ako 

value : door 
pane Is 

value : 0 
symmetry 

value : no 
doorway 

value : [] 


door 

ako 

value : thing 

area 

if_needed : door_area 


door_area(Door,Area) 

fget(Door,he Ight,Height), 
fget(Window,width,Width), 
Area Is Height * Width, 
frep I ace(Door,area,Area). 

siding.typel 
ako 

value : siding 
mater I a I 

value : clapboard 

width 

value : narrow 
cornerboard 

value : yes 

siding_type2 
ako 

value : siding 
materia I 

value : aluminum 

width 

value : wide 
cornerboard 

value : no 

siding 

ako 

value : thing 

house_type1 

ako 

value : house 
stories 

value : 3 
siding 

value : sidfng_type1 

roof 

value : gable 
windowl 

optional : yes 
xpositlon : 2 
yposition : 3 
type : window_type2 
window2 

xposition : 1 
yposition : 2 
type : window_type2 
window3 

xposition : 3 
yposition : 2 
type : wlndow_type2 

proto_house 

ako 

value : house_type1 
window4 

xposition : 1 
yposition : 1 
type : window_type2 

door 

xposition : 3 
yposition : 1 
type : door_type1 

proto_house_mirror_image 
ako 

value : house_type1 
window4 

xposition : 3 
yposition : 1 
type : window_type2 

door 

xposition : 1 
yposition : 1 
type : door_type1 
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1 1st ing3.pro 

TEXT 

"AI in Computer Vision." See oireod.me. 

house17 

xposition 

ako 

value : 1 

value : house 

yposition 

stories 

value : 2 

value : 3 


siding 

w17 

value : siding_type2 

ako 

roof 

value : window_type4 

value : gable 

ipo 

windowl 

value : house17 

value : w7 

xposition 

window2 

value : 3 

value : w12 

yposition 

window3 

value : 2 

value : w17 


window4 

w23 

value : w23 

ako 

door 

value : window_type3 

value : door37 

i po 


value : house17 

w7 

xposition 

ako 

value : 3 

value : window_type4 

yposition 

ipo /* is_part_of */ 

value : 1 

value : house17 


xpositIon 

door37 

value : 2 

ako 

yposition 

value : door_type3 

value : 3 

ipo 


value : house17 

w12 

xposition 

ako 

value : 1 

value : window_type4 

yposItion 

ipo 

value : 1 

value : house17 


app1graf.bas 


TEXT 


Programming Insight: "Easy 3-D Graphics," Henning 

Mittelbach. 

January, page 153. Apple version. 



10 REM *********************** 

20 REM APPLGRAF 

30 REM EASY 3-D GRAPHICS, BY 
40 REM HENNING MITTELBACH 
50 REM FOR PRIVATE, 

60 REM NON-COMMERCIAL USE ONLY 
70 REM *********************** 

90 DIM H(279) 

100 X0 « 110 
110 Y0 - 180 
120 PHI - .5 
130 PSI = .4 
140 XL - 0 
150 XR - 170 
160 YL - 0 

170 YR - 100 

180 D - 5 

190 REM * FUNCTION TO BE PLOTTED * 

200 DEF FN Y(X) - SIN (Y / F) * (X - Y) * (X - Y) / 150 

210 F ■ 10 

240 REM ^ABBREVIATIONS AND CUTTING THE TOP * 

250 CF - COS (PHI) :SF - SIN (PHI):CP - COS (PSI):SP - SIN (PSI) 
260 H - Y0 - XR * SF - YR * SP - 2 


(continued) 
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270 PRINT "DO YOU DESIRE CROSS-HATCHING? (Y/N):" 

275 INPUT OPT$ 

278 CH - 1 

280 IF OPT$ - "Y" OR OPT$ - "y" THEN CH - 2 
300 PRINT "DO YOU WISH TO VIEW THE AXES? (Y/N):" 

305 INPUT AX$: HGR2 : HCOLOR- 7 

310 IF AX$ - "N" OR AX$ - "n" THEN 340 

320 HPLOT X0 + XL * CF.Y0 - XL * SF TO X0 + XR * CF.Y0 - XR * SF 

330 HPLOT X0 - YL * CP,Y0 - YL * SP TO X0 - YR * CP.Y0 - YR * SP 

340 HPLOT 0,0 TO 279,0 TO 279,189 TO 0,189 TO 0,0 

400 FOR R - 1 TO CH 

420 FOR I - 0 TO 279:H(I) - 189: NEXT I 

430 ON R GOSUB 1000,2000 
440 NEXT R 

500 HCOLOR- 0 

510 HPLOT 0,0 TO 279,0 TO 279,189 TO 0,189 TO 0.0 

520 REM PRINTER ROUTINE FOR C.ITOH 

521 REM 8510 A PRINTER FOLLOWS. 

522 REM DELETE "REM" COMMANDS TO USE 
530 REM INPUT "PRINTING? (Y/N) ";J$ 

540 REM IF J$ - "N" THEN 600 

560 REM PR#1 

580 REM PRINT CHR$ ($14) 

590 POKE 1657,96: CALL 49661! 

600 REM PR#0 

700 END 

1000 REM 
1010 Y - YL 

1020 FOR X - XL TO XR 

1030 XB - INT (X0 + X * CF - Y * CP + .5) 

1040 Z = FN Y(X): IF Z > H THEN Z - H 

1050 YB = INT (Y0 - X * SF - Y * SP - Z + .5) 

1060 IF YB < H(XB) THEN H(XB) = YB 
1070 NEXT X 

1100 FOR X - XL TO XR STEP D 

1110 U = X0 + X * CF:V - Y0 - X * SF 

1120 FOR Y - YL TO YR 

1130 XB - INT (U - Y * CP + .5) 

1140 Z - FN Y(X): IF Z > H THEN Z - H 
1150 YB - INT (V - Y * SP - Z + .5) 

1160 IF YB < H(XB) THEN H(XB) = YB 

1200 FOR K » INT (U - YR * CP + .5) TO INT (U - YL * CP + .5) 

1210 HPLOT K,H(K) TO K + 1,H(K + 1) 

1220 NEXT K 
1230 NEXT X 
1240 RETURN 
2000 REM 
2010 X = XL 

2020 FOR Y - YL TO YR 

2030 XB * INT (X0 + X * CF - Y * CP + .5) 

2040 Z = FN Y(X): IF Z > H THEN Z - H 

2050 YB - INT (Y0 - X * SF - Y * SP - Z + .5) 

2060 IF YB < H(X8) THEN H(XB) - YB 
2070 NEXT Y 

2100 FOR Y - YL TO YR STEP D 

2110 U - X0 - Y * CP:V - Y0 - Y * SP 

2120 FOR X - XL TO XR 

2130 XB - INT (U + X * CF + .5) 

2140 Z - FN Y(X): IF Z > H THEN Z = H 
2150 YB - INT (V - X * SF - Z + .5) 

2160 IF YB < H(XB) THEN H(XB) - YB 
2170 NEXT X 

2200 FOR K = INT (U + XL * CF + .5) TO INT (U + XR * CF) - 1 
2210 HPLOT K,H(K) TO K + 1,H(K + 1) 

2220 NEXT K 
2230 NEXT Y 
2240 RETURN 
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gcd.bas 

TEXT 

Mathematical Recreations: "Euclid's Algorithm," by Robert T. Kurosaka. 
January page 397. Also download Icm.bas and eye Ifroc.bos. 


310 ’**********************************************<,*******« 

320 ’* EUCLIO'S ALGORITHM FOR GREATEST COMMON DIVISORS * 

330 ** BY ROBERT T. KUROSAKA * 

340 ******************************************************** 

350 CLS 

360 PRINT “This program calculates the greatest common divisor" 

370 PRINT "of a positive fraction" 

380 PRINT "and reduces the fraction to lowest terms." 

390 PRINT :PRINT 

400 INPUT "ENTER THE FRACTION'S NUMERATOR";NUM:NUM-ABS(NUM) 

410 INPUT "ENTER THE FRACTION'S DENOMINATOR";DEN:DEN-ABS(DEN) 

420 DIVISOR-NUM:DIVIDEND-DEN 'SAVE ORIGINAL VALUES FOR LATER DISPLAY 
430 REM IF EITHER TERM IS NOT A WHOLE NUMBER, CLEAR THE DECIMAL. 

440 IF DIVISOR<>INT(DIVISOR) OR DIVIDENDoINT(DIVIDEND) THEN 
DIVISOR-DIVISOR*10: 

DIVIDEND-DIVIDEND*10:NUM-DIVISOR:DEN=DIVIDENO:GOTO 440 
450 IF DIVISOR>DIVIDEND THEN SWAP DIVISOR, DIVIDEND 
460 WHILE DIVISOR>0 

470 QUOTIENT«INT(DIVIDEND/DIVISOR) 

480 REMAINDER-DIVIDEND-DIVISOR*QUOTIENT 

490 DIVIDEND-DIVISOR: DIVISOR-REMAINDER 

500 WEND 

510 PRINT :PRINT 

520 PRINT "THE FRACTION ";NUM;"/";DEN;" HAS A G.C.D. OF ";DIVIDEND 

530 IF DIVIDEND-1 THEN PRINT "THE FRACTION IS ALREADY IN LOWEST TERMS.“:GOTO 560 

540 PRINT "THE REDUCED FRACTION IS: ";NUM/DIVIDEND;" /";DEN/DIVIDEND; 

550 IF DEN/DIVIDEND-1 THEN PRINT " - ";NUM/DIVIDEND 
560 END 


Icm.bas 

TEXT 

Mathematical Recreations: "Euclid's Algorithm." See 
gcd.bos. 


10 ’********************************************** 

20 '* LEAST COMMON MULTIPLE ALGORITHM * 

30 ’* BY ROBERT T. KUROSAKA * 

40 '*******•***********•*****•••**•********••***** 

50 CLS 

60 PRINT "This program calculates the least common multiple" 

70 PRINT "of a set of positive Integers." 

80 PRINT 

90 INPUT "HOW MANY INTEGERS ARE IN THE SETTERMS:TERMS-INT(ABS(TERMS)) 

100 IF TERMS<2 THEN 400 

110 REM NUMBER ARRAY HOLDS THE SET OF INTEGERS FOR WHICH THE LCM IS SOUGHT. 

120 DIM NUMBER(TERMS) 

130 PRINT :PRINT "ENTER THE INTEGERS ONE AT A TIME." 

140 FOR 1-1 TO TERMS 
150 INPUT NUMBER(I) 

160 NUMBER(I)-INT(ABS(NUMBER(I))) 

170 IF NUMBER(I)»0 THEN PRINT "ILLEGAL ENTRY.":GOTO 150 
180 NEXT I 

190 REM BEGIN LCM PROCEDURE. 

200 LCM-NUMBER(I) 'THE LCM OF A SINGLE NUMBER IS ITSELF. 

210 FOR 1-2 TO TERMS 

220 REM FIND GCD OF ACTIVE ENTRY AND WHAT PRECEDED IT (GCD WILL BE STORED 
IN 'DIVIDEND' BECAUSE LINE 290 ASSIGNS LAST VALID DIVISOR TO 
DIVIDEND). 

230 DIVIS0R-NUM8ER(I):DIVIDEND-LCM 

240 REM LINES 250-300 ARE THE SAME AS 450-500 OF THE GCD ROUTINE. 

250 IF DIVISOR>DIVIDEND THEN SWAP DIVISOR.DIVIDEND 

260 WHILE DIVISOR>0 

270 QUOTIENT-INT(DIVIDENO/DIVISOR) 

(continued) 
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280 REMAINOER-DIVIDEND-DIVISOR*QUOTIENT 

290 DIVIOENO-DIVISOR:DIVISOR-REMAINDER 

300 WEND 

310 LCM-NUMBER(I)* LCM/DIVIDEND 

320 REM THE LAST LCM WILL BE LCM OF ALL THE ENTRIES. 

330 NEXT I 

340 PRINT :PRINT 

350 PRINT "THE LEAST COMMON MULTIPLE OF"; 

360 FOR 1-1 TO TERMS 
370 PRINT NUMBER(I); 

380 NEXT I 

390 PRINT "IS";LCM 

400 END 


cyclfrac.bas 
TEXT 

Mathematical Recreations: "Euclid’s Algorithm," Robert T. Kurosaka. 
Listing 3, page 402. 


10 *********************************************************** 

20 '* REPEATING DECIMAL TO FRACTION CONVERTING ROUTINE * 

30 •* BY ROBERT T. KUROSAKA * 

50 CLS 

60 PRINT "Th1s routine can be used with the greatest common denominator" 

70 PRINT "program. Load the GCD program, then MERGE this routine into It." 

80 PRINT "The MERGEd program is designed to determine the reduced fractional" 
90 PRINT "representation of a repeating decimal.":PRINT 
100 PRINT "To ENTER a repeating decimal:": 

PRINT " Type the nonrepeating part, then a before the cycle." 
110 PRINT "For example, 1.2_345 Is the proper entry for 1.2345345345..." 

120 PRINT "The decimal should always precede the , l.e., .333... is 

entered": PRINT "as *._3'. Reversing the and will cause 

an error.":PRINT 

130 INPUT "ENTER REPEATING DECIMAL";NUMBER$ 

140 REM NON-REPEATING PART OF NUMBER IS THAT PART UP TO VAL OPERATOR 

IGNORES ALL NUMBERS AFTER A NON-NUMERICAL CHARACTER. THUS, IN 
1.2_345. VAL(“1.2_345") WILL BE 1.2, ETC. 

150 NONREPEATING.PART-ABS(VAL(NUMBER!)) 

160 REM DEFINE A MORE READABLE FUNCTION TO USE FOR THROWING THE LEFTMOST 
CHARACTER OF A STRING AWAY. 

170 DEF FNDROP.LEF T$(A$)=RIGHT$(A$,LEN(A$)-1) 

180 REM FIND DECIMAL POINT 

190 WHILE LEFT$(NUMBER$,1) <> "." 

200 NUMBER$«FNDROP.LEFT$(NUMBER$) 

210 WEND 

220 NUM8ER$=FNDR0P.LEFT$(NUMBER$) 

230 REM FIND OUT HOW MANY DECIMAL PLACES THE REPEATING CYCLE IS OFFSET FROM 
THE DECIMAL POINT. 

240 WHILE LEFT$(NUMBER$,1) o "_" 

250 OFFSET-OFFSET+1 

260 NUMBER$-FNDROP.LEFT!(NUMBER!) 

270 WEND 

280 REM THROW AWAY REPEATING PORTION MARKER, 

290 NUMBER!-FNDROP.LEFT!(NUMBER!) 

300 REM HOW MANY DECIMAL PLACES ARE IN THE CYCLE? SINCE THE REPEATING CYCLE 
IS EVALUATED AFTER THROWING AWAY THE DECIMAL POINT. MULTIPLY BY 
10‘-(TOTAL NUMBER OF PLACES TO THE RIGHT IT SHOULD BE SHIFTED). 

310 CYCLE.LENGTH-LEN(NUMBER!) 

320 REPEATING.CYCLE-VAL(NUMBER!)* 10"-(OFFSET+CYCLE.LENGTH) 

330 REM NUMBER-NONREPEATING PART+REPEATING CYCLE. SINCE THE FIRST ITERATION 
OF THE CYCLE IS THE ONLY ONE THAT DOES NOT CANCEL ON SUBTRACTION, ONLY USE 
IT. 

340 NUMBER-NONREPEATING.PART+REPEATING.CYCLE 

350 REM "CLEARED.NUMBER IS THE VALUE OF THE SUBTRACTION THAT DOES AWAY WITH 
THE INFINITE CYCLE (STEP 3 IN THE BYTE ARTICLE ALGORITHM). 

360 CLEARED.NUMBER-NUMBER*10‘CYCLE.LENGTH-NONREPEATING.PART 
370 REM NOW. ASSIGN THE VALUES OF THE NUMERATOR AND DENOMINATOR TO THE 
VARIA8LE NAMES USED IN THE GCD ROUTINE. 

380 NUM-CLEARED.NUMBER:DEN-10‘CYCLE.LENGTH-1 

390 REM I CONVERT NUM AND DEN TO STRINGS AND THEN BACK TO CLEAR THE GUARD 
DIGITS IN THE NUM AND DEN VARIABLES. SEE BYTE ARTICLE FOR DETAILS. 
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400 NUM$-STR$(NUM):DEN$«STR$(DEN):NUM-VAl(NUM$):DEN=VAL(DEN$) 
410 PRINT "THE EQUIVALENT UNREDUCED FRACTION IS:";NUM;"/“;DEN 
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frames.pro 
TEXT 

"AI in Computer Vision." See airead.me for details. 


/* get the Value of Slot in a given Frame */ 
frame_get(Frame,Slot,VaIue) 

ffget(Frame,Frame,Slot.Value). 


ffget(Parameter_Frame,Frame,Slot.Value) /* check for a value Facet */ 
fget(Frame,SIot,vaIue,VaIue). 

ffget(Parameter_Frame,Frame,Slot.Value) /* does it have a default? */ 
fget(Frame,SIot,defauIt,VaIue). 

ffget(Parameter_Frame,Frame,Slot.Value) /* how about a demon? */ 

fget(Frame,Slot,if_needed,RuIe), 

F =.. [RuIe,Parameter_Frame,Value], 

F. 


ffget(Parameter_Frame,Frame,Slot.Value) /* none of the above */ 

fget(Frame,ako,value,Parent), /* so, move up the hierarchy */ 

ffget(Parameter_Frame.Parent,Slot.Value). 


fget(Frame,Slot.Facet.Value) /* just grab the given Facet or fail */ 

F = .. [Frame,Slot.Facet.Value], 


/* put Value in Slot of a given Frame. If this Slot has an associated 
if_added demon, then grab it and execute It after installing the 
given Value. 

*/ 

frame_put(Frame,SIot,VaIue) 

get_ruIe(Frame,SIot,if_added,RuIe), /* must we do something extra */ 
fput(Frame,SIot,vaIue,VaIue), 

F [RuIe.Frame,VaIue], 

F. 

frame_put(Frame,Slot.Value) s- 

fput(Frame,Slot.value,Value). /* just a simple fput will do */ 

fput(Frame,Slot.Facet.Value) 

F «.. [Frame,Slot,Facet.Value], 
assertz(F). 


/* remove Slot from a given Frame. If the Slot has an associated 
if_removed demon, then grab the rule and execute it before , 
removing the Slot. 

*/ 

f rame_remove(Frame,SIot) 

get__ruIe(Frame,SIot,if_removed,RuIe), /* something extra to do */ 

F ■.. [RuIe.Frame], 

F, 

fremove(Frame,Slot). 
frame_remove(Frame,Slot) 

fremove(Frame,Slot). /* just a simple fremove */ 

fremove(Frame.Slot) 

F *.. [Frame,Slot.value,Value], 
retract(F). 

fremove(_,_). /* If Slot doesn't exist, then no harm done */ 


/* replace whatever is in Slot with Value. If the Slot has an associated 
if_repIaced rule, then grab it and execute it after doing the 
rep Iacement. 

[continued) 
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frame_repI ace(Frame,Slot.Value) 

get_rule(Frame,Slot.If_replaced,Rule). /* something extra to do */ 
frep I ace(Frame,Slot.Value), 

F -.. [Rule,Frame], 

F. 

frame_repI ace(Frame,Slot.Value) 

freplace(Frame.Slot.Value). /* just a simple replace */ 

frep Iace(Frame,Slot,VaIue) 

fremove(Frame.Slot), 
frame_put(Frame,SIot.Value). 


/* append Value to the list in Slot. If Slot has an associated 
if.appended rule, then grab it and execute it after appending 

the Value. 

*/ 

frame_append(Frame,Slot.Value) 

get_.ru I e(Frame ,S I ot , i f ..appended ,Ru I e) , 
f append(Frame,SIot,VaIue), 

F «.. [Rule,Frame], 

F. 

f rame__append(Frame ,S I ot ,Va I ue) 

fappend(Frame.Slot,Value). 


/* here we check to see if the slot already exists. 

If it does, then we just append the new Value to the old value list. 
If the Slot does not exist, then we create it and give it a value 
consisting of the list whose single element is Value. 

*/ 

fappend(Frame.Slot.Value) 

fget(Frame,Slot,value,Old). 

(member(VaIue,01d) 

fremove(Frame,Slot), 
fput(Frame,SIot.value,[Value101d]) 

fappend(Frame,SIot,VaIue) 

fput(Frame,Slot.value,[Value]). 


/* this is a simple utility predicate used to travel up the frame 
hierarchy looking for an appropriate rule to grab. 

*/ 

get_ruIe(Frame,SIot.Type.Rule) 

fget(Frame,SIot.Type.RuIe). 
get_.ru I e (Frame ,S I ot .Type.Ru I e) 

fget(Frame,ako,value.Parent), 
get_ruIe(Parent.Slot.Type.RuIe). 


/* Example 

frame representation: 

cyIinder 
ako 

value : thing 
height 

if_added : cyIinder_height_add 

if_removed : cy11nder_height_remove 
radius 

if_added : cy I inder__radius_add 

If_removed : cyIinder_radius_remove 
cross_section 

if_needed : cyIinder_cross_section 
voIume 

!f__needed : cy I inder_vo I ume 
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cyIinder1 
ako 

value : cylinder 


comments: cyllnderl above is an instance of cylinder. When we 
use frame-put(cylinderl,radius,2), say, the system wiI I install 
the number "2" as the value of cylinderl’s radius and it will 
further compute cylinderl's cross sectional area and install it 
under the cross_section slot. Similor actions take place when we 
do a frame_put for cylinderl’s height. Below is the Prolog code 
that implements all this. NOTE: PDPROLOG only supports integer 
arithmetic. 

*/ 


cyIinder(ako,value,geometric_object). 

cylinderfheight,if_added,cylinder.height_add). 

cylInder(height,if_removed,cyIinder_height_remove). 

cylinder ( radius,if_added,cylinder_radius_add). 

cylinder(radius,if_removed,cyIinder_radius_remove). 

cylinder(cross_section,if-needed,cylinder_cross_section). 

cylinder(voIume,if—ineeded,cyIinder_voIume). 


/* if we get the height, then we try to compute the cylinder’s 
voIume. 

*/ 

cylfnder_height_add(Cylinder,_) 

cylinder_voIume(CyIinder,_). 

cylfnder_height_add(_,_). /* if we can’t do it, 

e.g., the radius is unknown, 
then no harm done */ 

/* if the height is removed, then the old volume is no 
longer valid 

*/ 

cylinder_heIght_remove(CyIinder) 

frame_remove(CyIinder,voIume). 

/* if we get the radius, then we can compute the cylinder’s 
cross sectional area 

*/ 

cylInder_radius_add(CyIinder,_) 

cylinder_cross_section(CyIinder,_). 

/* if the radius Is removed, then the old cross sectional area 
Is no Ionger valid 

*/ 

cyllnder_radIus_remove(CyIinder) 

f r ame_remove(CyIinder,cross_section), 
frame_remove(CyIinder,voIume). 

/* PDPROLOG does not support floating-point arithmetic, so pi has been 

approximated as 3. If you are using a commercial prolog, change 3 to 3 1416 

*/ 

cyl1nder_cross_section(CyIinder,Cross_Section) 
f rame_get(CyIinder,radius.Radius), 

Cross-Section Is 3*Radius*Radius, 
frep I ace(Cylinder,cross_section,Cross_Section). 

cylinder-voIume(CyI Inder,Vo Iume) 

frame.get(Cylinder,cross_section,Cross_Section), 
frame-get(Cylinder,height,Height), 

Volume is Height♦Cross-Sect ion, 
f rep I ace(Cylinder,voIume,Vo Iume). 

cylinderl(ako,value,cylInder). 
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Iisting.txt 
TEXT 

Ciorcio’s Circuit Cel lor: "Build on Anolog-to-Digitol Con verter." Steve Clorcia. 
January, poge 104. 


10 CLEAR 

20 REM READ AND DISPLAY A/D CHANNELS 0-7 
30 REM SINGLE ENDED OR DIFFERENTIAL 
40 REM -5 TO +5 VOLT INPUT 
50 REM 
60 REM 

70 N=47104 : REM BOARD ADDRESS 
80 REM STATUS BIT IS B5 - LOGIC 1 IS RESET 
90 FOR A=0 TO 7 : REM DO ALL CHANNELS 0-7 
100 GOSUB 160 : REM READ A CHANNEL 
110 NEXT A : REM NEXT CHANNEL 

120 PRINT CHR(18),CHR(27),"Y" : REM TERMITE - HOME AND CLEAR SCREEN 
130 REM DISPLAY ARRAY HOLDING CHANNEL 0-7 READINGS 

140 PRINT USING(#.###),A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),"VOLTS 
150 GOTO 20 : REM DO IT AGAIN 


160 XBY 
170 XBY 


(N)= 

(N> 


■A + 16 : REM RESET A/D AND SET MUX CHANNEL 
■A : REM CLEAR STATUS BIT TO READ DATA 
180 DI-XBY(N) : D2-XBY(N) : REM READ 12 BITS AS 2 SUCCESSIVE WORDS 
190 R-.0012207 : REM VOLTS PER COUNT 
200 IF DI>«*240 THEN GOTO 230 

210 A(A)-R*((D1*256)+D2) : REM SAVE POSITIVE READING IN ARRAY 
220 RETURN 

230 D1-255-D1 : D2-255-D2 : REM ADJUST D1 4 D2 FOR 2’S COMPLEMENT 
240 A(A)«-1*R*((D1*256)+D2) : REM SAVE NEGATIVE READING IN ARRAY 
250 RETURN 


macgraf.bos 
TEXT 

Programming Insight: "Easy 3-D Grophlcs." Henning Mittlebach. 
January, page 153. Macintosh version. 


**************************************** 

MacGraf - Easy 3-D Graphics on the Macintosh 

by 

Henning MIttelbach 

Copyright 1985, for private, non-commercial 

use only. 

**************************************** 


10 * 

20 * 

30 * 

40 ’ 

50 ' 

60 * 

70 ’ 

80 CLS 

90 DIM H (279) 

100 X0-110 
110 Y0-180 
120 PHI-.5 
130 PSI-.4 
140 XL- 0 
150 XR- 170 
160 YL-0 
170 YR-100 
180 D-5 

198 ' 

199 ' 

200 DEF FN Y(X) 

210 F-10 

24 0 • * ABBREVIATIONS AND CUTTING THE TOP * 

250 CF- COS (PHI) : SF-SIN(PHI) : CP- COS (PSI) : SP- SIN(PSI) 

260 H-Y0 - XR * SF -YR * SP - 2 

270 INPUT "Do you desire cross-hatching? (Y/N):“, 

280 IF opt$-"Y" OR opt$«“y" THEN ch»2 ELSE ch=1 
300 INPUT "Do you wish to view the axes? (Y/N):“, 

310 CLS : IF AX$-“Y" OR ox$«"y" THEN 320 ELSE 340 

320 LINE (X0 + XL * CF. Y0 - XL * SF) -(X0 + XR * 

330 LINE (X0 - YL * CP. Y0 - YL * SP) -(X0 - YR * 

340 LINE (0.0) - 
350 


* FUNCTION TO BE PLOTTED * 
SIN (Y/F) * (X-Y) * (X-Y)/150 


opt$ 

AX$ 


"(279,189),,B 


CF. 

CP. 


Y0 - XR 
Y0 - YR 


SF) 
SP ) 


12 
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398 • R-1: 

399 ' R«2: 

400 FOR R - 1 TO ch 
410 * 

420 FOR I - 0 TO 279: H(I) 

430 ON R GOSUB 1000, 2000 
440 NEXT R 

499 ' 

500 BEEP 

510 LINE (0.0) - (279,189)..B 


Y-COORD. 

X-COORO. 


LINES 

LINES 


* SETTING MASK ON LOWER BORDER OF WINDOW * 
= 189: NEXT I 


* GRAPHIC IS FINISHED * 


IF a$= 


THEN 520 


* END OF PROGRAM * 

* Y-COORD. LINES FOR X 

* FRONT MASK SETTING * 


CF - Y * CP + .5) 
> H THEN 2 - H 
SF - Y * SP - Z + 
YB 


CONST. * 


.5) 


520 o$=» INKEY$: 

600 END 
$10 * 

1000 1 

1010 Y - YL: • 

1020 FOR X - XL TO XR 
1030 XB = INT (X0 + X * 

1040 Z - FN Y(X) : IF Z 
1050 YB = INT (Y0 - X * 

1060 IF YB < H(X8) THEN H(XB) 

1070 NEXT X 

1090 * ADAPTING THE MASK PER LINE * 

1100 FOR X - XL TO XR STEP D 

1110 U - X0 + X * CF : V - Y0 - X * SF 

1120 FOR Y - YL TO YR 

1130 XB = INT (U - Y * CP + .5) 

1140 Z - FN Y(X) : IF Z > H THEN Z - H 

1150 YB - INT (V - Y * SP - Z + .5) 

1160 IF YB < H(XB) THEN H(XB) « YB 

1170 NEXT Y 

1190 ' * PLOTTING THE MASK * 

1200 FOR K - INT (U - YR * CP + .5) TO INT (U - YL * CP + .5) - 1 
1210 LINE (K.H(K)) - (K + 1,H(K+1)) 

1220 NEXT K 
1230 NEXT X 
1240 RETURN 
2000 * 

2010 X - XL: • 

2020 FOR Y - YL TO YR 
2030 XB - INT (X0 + X * 

2040 Z - FN Y(X) : IF Z 

2050 YB - INT (Y0 - X * SF - Y * SP - Z + .5) 

2060 IF YB < H(X8) THEN H(XB) - YB 
2070 NEXT Y 

2090 ’ * ADAPTING THE MASK PER LINE * 

2100 FOR Y - YL TO YR STEP D 
2110 U - X0 - Y * CP : V ■ Y0 - Y * SP 
2120 FOR X - XL TO XR 

X * CF + .5) 

IF Z > H THEN Z - H 
2150 YB - INT (V - X * SF - Z + .5) 

2160 IF YB < H(X8) THEN H(XB) - YB 
2170 NEXT X 
2190 • 

2200 FOR K - INT (U ♦ XL 
2210 LINE (K.H(K)) - (K + 1,H(K+lj$ 

2220 NEXT K 
2230 NEXT Y 
2240 RETURN 


* X-COORD. 
* FRONT MASK SETTING * 


LINES FOR Y = CONST. * 


CF - Y * CP + .5) 
> H THEN Z - H 
SF - Y * SP - Z + 


2130 XB - INT (U + 
2140 Z - FN Y(X) 


PLOTTING THE MASK * 

CF + .5) TO INT (U + XR * CF) - 1 


editsort.md2 
TEXT 

"Creating Reusable Modules," Namir Clement Shammas. 
January, page 145. Also download quiksort.md2. 


EDITS0RT.MD2 
MODULE Ed ItSort; 

(* -* 

(* This module Is the capsule editor for the procedure Quicksort. ♦ 


{continued) 


BYTE LISTINGS SUPPLEMENT 13 









January 

! * This editor will perform the following: 

* 

* (1) Customize the procedure nome. 

* (2) Customize the Record type decloratlon. 

* (3) Customize the keys for sorting. _ 

FROM Strlibl IMPORT Stringls, StrtngAdd. StringRemove. StringRepI 
ShowString, StringLeft. Inputstring, ten. 
StringPos, eos; 

FROM FileSystem IMPORT File, Response, Lookup, Close, ReodChor, 

WriteChor; 

FROM InOut IMPORT ReadCard, WriteCard; 

FROM Terminal IMPORT WrlteLn; 

CONST MAXKEY - 10; 

MAXSTRING - 80: 

EOL - 36C ; 

TYPE String - ARRAY [1..MAXSTRING] OF CHAR; 

VAR I. J, k, n : CARDINAL: 
ch : CHAR; 

Line, Str, Sortnome. Recname, YourFile, Fldname : String; 
Subkey : ARRAY [1..MAXKEY] OF String; 
f1. f2 : File; 

PROCEDURE GetLine; 

(* Procedure to read the next text line from QWKSORT.CAP file. 

(* Insert on End Of String (eos) If string is not full. 

BEGIN 

I 0; 

REPEAT 

ReadChar(f1,ch); 

INC(i); 

Line[!] :«■ ch 
UNTIL ch - CHAR(EOL) ; 

IF i < MAXSTRING THEN Llne[i + 1] :« eos END; 

END GetLine; 

PROCEDURE PutLine; 

(* Procedure to write o text line In the user specified output 
(* file. If the line is generated by this program, append an 
(* End-Of-Line (EOL) character to the text line. 

BEGIN 

I :» Len(Line); 

IF i>0 THEN 

FOR j 1 TO i DO 
ch ;= Line[j]; 

Wr i teChar(f2.ch) 

END; 

IF ch <> CHAR(EOL) THEN 
WriteChar(f2.CHAR(EOL)) END; 

END; 

END PutLine; 

PROCEDURE ScanSkip(Match : ARRAY OF CHAR); 

Procedure will read a text line from file QWKSORT.CAP and 
(# attempt to locate string 'Match' in it. If no match is 
(* found, the line is written to output text file. 

VAR Pos : CARDINAL; 

BEGIN 

Pos :■ 0; 

WHILE Pos - 0 DO 
GetLine; 

Pos :■ StrlngPos(Line.Match,1); 

IF Pos - 0 THEN PutLine END; 

END; 

END ScanSkip; 

PROCEDURE OneSort; 

(* Procedure to customize the dummy key field 
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BEGIN 

(* Edit record type. *) 

ScanSkIp(“Item"); 

StrIngReplace(LIne,"Item".Recname); PutLIne; 

(* Enter sort key and edit the 'dummy' key. *) 

ShowStrlng("Enter fieldname ? "); InputStrJng(Fldname); 
FOR k 1 TO 2 00 

ScanSklp("key"); StrIngReplace(Llne."key'',Fldnome); 
PutLIne ' 

ENO; 

END OneSort; 


PROCEDURE Mu 111 Sort; 

(* Procedure to establish multikey sorting. *) 


BEGIN 

(* Enter the number of sort fields and their names. *) 
ShowStringf"Enter number of fields used ? "); 

ReadCard(n); 

WriteLn; 

FOR k 1 TO n DO 

ShowStr ing(''Enter name for subkey # "); 

Wr i teCard(k,2); 

ShowString(" “); InputString(Subkey[k]); 

WrIteLn 


END; 

(* Edit the arguments In the procedure coll, changing them 
(* from arrays of character to the user specified record tvoe 
ScanSkipf-SI. S2 ' 

StringIs(Str,"R1, R2 : "); 

StringAdd(Str.Recname); StringRepI ace(Line."SI, S2 : 

ARRAY OF CHAR".Str); 

PutLIne; 

ScanSkIp("I : CARDINAL;"); PutLIne; 

(* Insert the declaration for the strings used in the 
(* comparison. 

StringIs(Line," SI. S2 : ARRAY [1.YourMaxString] OF CHAR;"); 
PutLine; 

ScanSkip("i 0"); PutLine; 

(* Build the text line that represents the code for the 
(* build-up of the multifield sort string. 

StrIngIs(Line."St ring Is(SI,R1."); StringAdd(Line.Subkeyril)- 
StringAdd(Line,") ; Strlngls(S2.R2."); 1 

StringAdd(Line,Subkey[1]); 

StrIngAdd(Line,") ;“) ; PutLine; 

IF n > 1 THEN 
FOR k 2 TO n DO 


StringIs(LIne." StrlngAdd(S1,R1."); 

StringAdd(Line.Subkey[k]); 

Str i ngAdd (Line, *') ; Str ingAdd(S2.R2.'•) ; 
StringAdd(Line.Subkey[k]); 

StrlngAdd(Llne,") ;") ; PutLine 
ENO; 

END; 


*) 

*) 


:! 

:) 


(* Edit record type for the locally declared records. 
SconSkip("Item"); 

StringRepIace(LIne,"Item".Recname); PutLine; 

(* Edit the call to the Compare procedure. 

FOR k 1 TO 2 DO 

END COnSkiP( "' k * y " 5 Str,n 9 R « mov «( Lin *-"- k ®y M ): PutLine 
ENO MultiSort; 


BEGIN (* Main module *) 

ShowString("Enter the output filename ? "); 

InputString(YourFile); WriteLn; 

Lookup(f1."c:qwk sor t.cap."FALSE); 

Lookup(f2.YourFile.TRUE); 

(* Check if both files are opened correctly. 

IF (fl.res - done) AND (f2.res - done) THEN 
ShowStrlng("Enter new procedure name ? "); 

InputStrIng(Sortname); 

WrIteLn; 

GetLIne ; StrIngRepIace(Line,"QuIckSort."Sortnome); 


{continued) 
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ShowString("Enter record type nome ? “): 

InputString(Recnome); 

WrlteLn; .. , 

StrIngRepIoce(Llne,"Item".Recnome); PutLine; 

GetLIne ; GetLIne; (* * Skip the two comment lines *) 

ShowStrlng(“Is the sort based on one field ? “); 
InputStrlng(Str); WrlteLn; A . . \ 

StrIngLeft(Str,Str, 1); (* Extract the leftmost character *) 

IF CAP(Str[1]) - "Y" THEN OneSort ELSE MultlSort 
END * 

ScanSk lp( H QulckSort M ) ; Str IngRepIace(Llne, "Quicksort* 4 , 

Sortname); 

PutLine; 

ELSE 

ShowStrlng("Error In locating fI Ie QWKSORT.CAP") 


IF (fi.ree - done) THEN Closeffl) END; 
IF (f2.res ■ done) THEN Close(f2) END; 
END EdltSort. 


readsim2.me 
TEXT 

"A SIMPL Compiler, Part 2: Procedures and Functions." See simpl2.txt. 


SRM70O 

Guide to Part 2 of the SIMPL Compiler 

This code accompanies part 2 of "A SIMPL Compiler." It includes 
Modula-2 source code for the entire SIMPL Compiler. You will need 
the Monitor program from Building a Computer in Software (October 

*85) and the VM2 Assembler (November *85). There are 12 modules to 
the compiIer: 


CodeGen 

CodeWrlte 

Compiler (MOD file only) 

ExprParser 

LexAn 

Node 

Parser 

Routines 

SymboI 

SymboI Tab Ie 

Token 

TypeChecker 


[Editor’s note: The above files were combined 
were put on the bulletin board. You will need 
Into a separate file to compile them.] 


Into one 
to break 


file 

each 


when they 
moduIe 


You 

the 

the 


Will also need to compile the following utility modules along with 
12 above. These modules can be found with those downloaded with 
VM2 Monitor: 


CharStuff 
LexAnStuf f 
MyTerminaI 
StringStuff 


The programs were developed using MacModula-2 for the Macintosh, but 
conversion to other Modula-2 systems should be straightforward, 
would appreciate hearing about any conversion difficulties or bugs. 
You can reach me on BIX as "jbo" or by U.S. mail at 1643 Cambridge 
St. #34. Cambridge. MA 02138. Happy CompiIing! 


Jonathan Amsterdam 
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pcgraf.bas 
TEXT 

Programming Insight: "Easy 3-D Graphics," Henning Mittlebach. 
January, page 153. IBM version. 


********************************************** 

* PCGRAF - Easy 3-D Graphics on the IBM PC * 

* by * 

* Henning Mittelbach * 

* Copyright 1985, for private non-commercial * 

* use only. * 

********************************************** 


10 * 

20 * 

30 # 

40 # 

50 * 

60 * 

70 • 

80 CLS: SCREEN 1 
90 DIM H (279) 

100 X0-110 
110 Y0-180 
120 PHI-.5 
130 PSI-.4 
140 XL- 0 
150 XR- 170 
160 YL-0 
170 YR-100 
180 D-5 

198 • 

199 * 

200 DEF FN Y(X) 

210 F-10 

240 * * ABBREVIATIONS AND CUTTING THE TOP * 

250 CF= COS (PHI) : SF-SIN(PHI) : CP- COS (PSI) : SP- SIN(PSI) 
260 H-Y0 - XR * SF -YR * SP - 2 

270 INPUT "Do you desire cross-hatching? (Y/N):",OPT$ 

280 IF OPT$="Y" OR OPT$-"y" THEN CH-2 ELSE CH-1 
300 INPUT "Do you wish to view the axes? (Y/N):",AX$ 


* FUNCTION TO BE PLOTTED * 
SIN (Y/F) * (X-Y) * (X-Y)/150 


IF AX$ 
(X0 + XL 
(X0 - YL 
( 0 . 


"Y" OR AX$ 

* CF. Y0 - XL 

* CP, Y0 - YL 
0) - (279,189),,B 


y" THEN 320 ELSE 340 


* SF) -(X0 + XR 

* SP) -(X0 - YR 


CF, 

CP. 


> 1 : 

2: 


Y-COORD. 

X-COORD. 


LINES 

LINES 


* SETTING MASK ON LOWER BORDER OF WINDOW * 
= 189: NEXT I 


* GRAPHIC IS FINISHED * 


IF A$="" THEN 520 


310 CLS 
320 LINE 
330 LINE 
340 LINE 
350 * 

398 • 

399 • 

400 FOR R - 1 TO CH 
410 • 

420 FOR I - 0 TO 279: H(I) 

430 ON R GOSUB 1000, 2000 
440 NEXT R 

499 ' 

500 BEEP 

510 LINE (0.0) - (279.189),,B 
520 A$»INKEY$: ' 

600 END 
610 * 

1000 ’ 

1010 Y - YL: * 

1020 FOR X - XL TO XR 
1030 XB - INT (X0 + X 
1040 Z - FN Y(X) : IF 
1050 YB - INT (Y0 - X 
1060 IF YB < H(XB) THEN H(X8) 

1070 NEXT X 

1090 ’ * AO APT ING THE MASK PER LINE * 

1100 FOR X - XL TO XR STEP 0 
1110 U - X0 + X * CF : V - Y0 - X * SF 
1120 FOR Y - YL TO YR 
1130 XB - INT (U - Y * CP + .5) 

IF Z > H THEN Z - H 
INT (V - Y * SP - Z + .5) 

THEN H(XB) - YB 


Y0 - XR * SF) 
Y0 - YR * SP ) 


* END OF PROGRAM * 

* Y-COORD. LINES FOR X 
* FRONT MASK SETTING * 


CONST. * 


CF - Y * CP + .5) 
> H THEN Z - H 
SF - Y * SP - Z + 
YB 


•5) 


1140 Z - FN Y(X) 


1150 YB 


H(XB) 


1160 IF YB < 

1170 NEXT Y 
1190 ’ 

1200 FOR K - INT (U - YR 
1210 LINE (K.H(K)) - (K + 


* PLOTTING THE 


■ CP + .5) 
1,H(K+1)) 


TO 


MASK * 

INT (U - YL * 


CP + .5) - 1 


\ 


( continued ) 
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1220 

1230 

1240 

2000 

2010 

2020 

2030 

2040 

2050 

2060 

2070 

2090 

2100 

2110 

2120 

2130 

2140 

2150 

2160 

2170 

2190 

2200 

2210 

2220 

2230 

2240 


NEXT K 
NEXT X 
RETURN 


* X-COORO. LINES FOR Y - CONST. 
* FRONT MASK SETTING * 


CF - Y * CP ♦ .5) 
> H THEN Z « H 
SF - Y * SP - Z + 
YB 


.5) 


X ■ XL: ’ 

FOR Y - YL TO YR 
XB - INT (X0 + X 
Z - FN Y(X) : IF 
Y8 - INT (Y0 - X 
IF YB. < H(XB) THEN H(XB) 

NEXT Y 

• * AOAPTING THE MASK PER LINE * 
FOR Y - YL TO YR STEP D 

U - X0 - Y * CP : V - Y0 - Y * SP 

FOR X - XL TO XR 

XB « INT (U + X * CF + .5) 

Z - FN Y(X) : IF Z > H THEN Z - H 
YB - INT (V - X * SF - Z + .5) 

IF YB < H(XB) THEN H(XB) - YB 
NEXT X 

• * PLOTTING THE MASK * 

FOR K - INT (U + XL * CF + .5) TO INT (U + XR * CF) 
LINE (K.H(K)) - (K + 1.H(K+1)) 

NEXT K 
NEXT Y 
RETURN 


quiksort.md2 

TEXT 

"Creating Reusable Modules." See editsort.md2. 


QUIKSORT.MD2 

(* This module should be saved under 


the name QWKSORT.CAP. 


*> 


PROCEDURE QulckSort( A : ARRAY OF Item ; N : CARDINAL ); 
(* Capsule Quicksort: A skeleton procedure for using the 
(* quicksort algorithm. See reference 3. 

PROCEDURE Compare ( SI. S2 : ARRAY OF CHAR): BOOLEAN; 

(* Compare two strings of the same maximum lengths. 

CONST eos - 0C; (* End-Of-String *) 

VAR Less. Stop : BOOLEAN; 
i ; CARDINAL; 


BEGIN 

Less := FALSE; 

Stop :* FALSE; 

WHILE (i <- HIGH(SI)) AND (Less = FALSE) AND (Stop * FALSE) DO 
IF (SI[i] <> eos) AND (S2[i] <> eos) 

THEN (* Proceed in comparison *) 

IF (SI[i] < S2[i1) THEN Less := TRUE ELSE INC(i) END; 
ELSE Stop := TRUE (* Reached the end of string *) 

END; 

END; 

RETURN Less; 

END Compare; 

PROCEDURE Sort( L. R : CARDINAL); 

VAR i. j : CARDINAL; 

X. W : Item; 


BEGIN 

X := A[(L + R) DIV 2]; 

REPEAT 

WHILE Compare(A[i].key.X.key) DO INC(i) END; 
WHILE Compare(X.key,A[i].key) DO DEC(j) END; 
IF i <= j THEN 


\ 
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w = A 
INC( 
END; 


A[i] := A[i] 
U : DEC(j) 


A[i] 


UNTIL i > j ; 

IF L < j THEN Sort(l.j) END; 
IF i < R THEN Sort(i.R) END; 
ENO Sort; 


A[j] ; A[j] ;= W ; 


BEGIN 


Sort(I.N) 
END QuickSort; 


simpl2.txt 

TEXT 

Programming Project: "A SIMPL Compiler. Part 2: Procedures and Functions." Jonathan Amsterdam. 

January, page 130. Code for the revised SIMPL compiler. Also download 

readsim2.me. 


E+++++++ 

Editor's note: Break each of the files into a separate file. Be sure and 
delete the notes surrounded by plus signs. 

Start CodeGen.DEF 
+++++++ 

DEFINITION MODULE CodeGen; 

(* This module generates code from parse trees. *) 

FROM Node IMPORT node; 

FROM Symbol IMPORT symbol; 

EXPORT QUALIFIED genBlock. genGlobal, genLocals; 

PROCEDURE genBlock(n:node); 

(* Generate code for a block of statements. *) 

PROCEDURE genGIobaI(s:symboI); 

(* Generate code for a global variable. *) 

PROCEDURE genLocaIs(routine:symbol); 

(* Generate code to set up the stack for local variables. *) 

END CodeGen. 

+++++++ 

Start CodeGen.MOD 
+++++++ 

IMPLEMENTATION MODULE CodeGen; 

(* Code Generator for the SIMPL compiler. *) 

IMPORT MyTermlnaI; 

FROM InOut IMPORT WriteString, WriteLn; 

FROM Node IMPORT node, nodeClass, NodeClass, nodeEmpty, nodeFirst, nodeRest, 
nodeTest, nodeThen, nodeElse, nodeStmts, nodeRHS, nodeLHS, nodeArgs! 
nodeRoutine, nodeExpr, nodeArg, nodeLeftArg. nodeRightArg, nodeOp, 
nodeSymbol, nodelnt, nodeBool, nodeNumFormaIs, nodeChar, 
nodeType, freeNode; 

FROM CodeWrite IMPORT writeLabel, writeStringLabeI, writeStringBranch, 
wrIteCondBranch, writeBranch, writePop, writeCall, writeChar, 
writeWritelnt, writelnt, wrlteReadlnt, writeReturn, writeFReturn, 
writeOp, writeBool, writeSymbol, writeWrIteChar, writeReadChar; 

FROM Token IMPORT tokenClass, isRelation, strlngType, typeType; 

FROM LexAn IMPORT errorFlag; 

FROM Symbol IMPORT symbol, symboILexLeveI, symboI String, numLocals; 

(*** label generation ***) 

(* The code generator needs a supply of unique label names. *) 

( continued ) 
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MODULE LabeIGenerator; 

EXPORT newLabeI, IabeI; 

TYPE label - CARDINAL; 

VAR I abe ICount -.CARDINAL; 

PROCEDURE newLabeI():label; 
BEGIN 

INC(IabeICount); 

RETURN label(IabeICount); 
END newLabeI; 

BEGIN 

labelCount 0; 

END LabeIGenerator; 


PROCEDURE genBlock(n:node); don .* wa8 t« our time 

BEGI IP (NOT errorFlog) AND (NOT nodeEmpty(n)) THEN 

IF nodeClass(n) <> nList THEN . . t ,». 

MyTerminol.fatal(’genBlock: node class must be nList ). 

ELSE 

genStmts(n^ 


f reeNode 




END; 


END; 

END genBlock; 

PROCEDURE genGIoboI(s:symbol); initialize integers to 0, booleans 

VAR nametstringType; 

BEGIN , . 

symbolString(8, nome); 

IF symboILexLeveI(s) - 0 THEN 
wrIteStrIngLabeI(name); 

WrIteStrIng(" 0"): 

WriteLn; 

ELSE M yTermlnal .WrlteStrlna("genGlobal: not o global: "): 

MyTermtnal.fatal(name); 

END; 

END genGlobal; 

^55“^ e (or FALSE. or KUL) .) 

VAR I:CARDINAL; 

BEGIN 

FOR 1 1 TO numLocaIs(routine) DO 

wr itelnt(0); 

END; 

END genLocaIs; 

»0. oodo ompty. .) 

BEGIN 

IF NOT nodeEmpty(n) THEN 


END; 

END genStmts; 


v » liwuvw» r v\"/ / \\ 

genStmt(nodeFIrst(n)); 
genStmts(nodeRest(n)); 


(*** Statements ***) 


PROCEDURE genStmt(n:node); 

BEGIN / X nr 

CASE nodeCloss(n) OF 
nlf: genlfStmt(n); 

| nWhlle: genWhileStmt(n); 

nAssignment: genAssignStmt(n); 
I nCall; genCalIStmt(n); 
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nWrIt«: genWrlteStmt(n); 
nRead: genReadStmt(n); 
nReturn: genReturnStmt(n); 

ELSE 


MyTerminaI.fatal("genStmt: 

END; 

END genStmt; 


unknown statement type"); 


PROCEDURE genIfStmt(n:node); 

VAR label 1, Iabe12:IabeI; 

BEGIN 

I abe11 := newLabeIQ; 
genExpr(nodeTest(n)); 
wr IteCondBranch(Equal, label 1); 

*) 

genBlock(nodeThen(n)); 

IF nodeEmpty(nodeEIse(n)) THEN 
wr i teLabeI(IabeII); 

ELSE 

Iabe12 :* newLabeI(); 
wrIteBranch(Iabe12); 
wr IteLabeI(label 1); 
genBlock(nodeEIse(n)); 
wr IteLabeI(IabeI 2); 

END; 

END genlfStmt; 

PROCEDURE genWhI IeStmt(n:node); 

VAR testLabeI, endLabeI;IabeI; 

BEGIN 

testLabel :« newLabel(); 

endLabel ;* newLabelQ; 

wrIteLabeI(testLabeI); 

genExpr(nodeTest(n)); 

wrIteCondBranch(EquaI, endLabeI); 

genBlock(nodeStmts(n)); 

wrIteBranch(testLabe I); 

wr IteLabeI(endLabeI); 

END genWhI IeStmt; 


(* generate test *) 

(* branch to else part If test false 

(* generate then part *) 

(* no else part *) 


* branch around els part *) 

* label for else part *) 

* generate else part *) 

(* final label *) 


(* label for top of loop *) 

(* generate test *) 

(* if false, branch to end of loop *) 
(* generate loop body *) 

* branch back to test *) 

* end label *) 


PROCEDURE genAssignStmt(n:node); 
BEGIN 

genExpr(nodeRHS(n)}; 
wrItePop(nodeLHS(n)); 

END genAssIgnStmt; 

PROCEDURE genCalI Stmt(n:node); 
BEGIN 

genExprLIst(nodeArgs(n)}; 
wrIteCaI I(nodeRoutine(n)); 
END genCaIIStmt; 


* generate the expression *) 

* pop the result into the variable *) 


* generate the arguments *) 

* generate a call instruction *) 


PROCEDURE genWrIteStmt(nmode); 

(* Generate code to write the arguments to the screen. WRITE can take any 
number of arguments. *) 

VAR argl 1st mode; 

BEGIN 

argl1st :* nodeArgs(n); 

WHILE NOT nodeEmpty(argI 1st) DO 
genExpr(nodeFirst(arglist)); 

CASE nodeType(nodeFirst(argIist)) OF 
tlnteger: wrIteWritelnt; 

| tChar: wrIteWrIteChar; 

ELSE 

MyTerminaI.fata I("genWriteStmt; iI legal type"); 

END; 

arglIst :■ nodeRest(argI Ist) ; 

END; 

END genWriteStmt; 


PROCEDURE genReadStmt(nmode); 

(* Generate code to read from the terminal. READ can take any number of 
arguments. *) 

VAR argl ist mode; 


{continued) 
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BEGIN . . 

arglist nodeArgsfn); 

WHILE NOT nodeEmpty(orgl1st) DO 

CASE nodeType(nodeFirst(argI 1st)) OF 
tlnteger: wr1teReadlnt; 

I tChar: wrIteReadChar; 


ELSE 

MyTermlnaI.fatal("genReadStmt: Illegal type"); 

wr ItePop(nodeSymbol(nodeFirst(arglist)))* 
arglist nodeRest(argI Ist); 

END; 

END genReadStmt; 


PROCEDURE genReturnStmt(n:node); 

BEGI IF nodeEmpty(nodeExpr(n)) THEN (* o procedure return *) 
wrIteReturn(nodeNumFormaIs(n)); 

£LSE (* a function return *) 

genExpr(nodeExpr(n)); 
writeFReturn(nodeNumFormaIs(n)); 

END; 

END genReturnStmt; 

(*** expressions ***) 


PROCEDURE genExprLIst(nmode); 
VAR el mode; 

BEGIN 

el :* n; 

WHILE NOT nodeEmpty(eI) DO 

genExpr(nodeFirst(el)); 
el := nodeRest(el); 

END; 

END genExprList; 


PROCEDURE genExpr(n;node); 

BEGIN 

CASE nodeCIass(n) OF 

nUnop; genExpr(nodeArg(n)); 

wr1teOp(nodeOp(n)); 

| nOp: IF (nodeOp(n) » And) OR (nodeOp(n) 

genLogicalOp(n); 

ELSE , XN 

genExpr(nodeLef tArg(n)); 


Or) THEN 


genExpr ( nodeRightArg(n)); 
writeOp(nodeOp(n)); 

E ND; , 

nlnt: writeInt(nodeInt(n)); 

nBool: writeBooI(nodeBooI(n)); 

nChar; writeChar(nodeChar(n)); 
nSymbol:writeSymboI(nodeSymbol(n)); 

nCall: genCalIStmt(n); . 

ELSE MyTerminal.fatal("genExpr; unknown expression type 

END; 

END genExpr; 


PROCEDURE genLogicaIOp(nmode); 

(* AND’s and OR’s end up here. We generate code to evaluate only the first 

if possible. *) 

VAR label 1, label2:label; 

BEGIN 

label 1 :■ newLabel(); 

Iabel2 :« newLabel(); 

IF n nodeOp(n) L = And^HEN (* we branch to FALSE if the first was FALSE *) 
ELSE W (i t tt < 's d ORrwe ( branch to^TRUE' I f the first was TRUE *) 

wrIteCondBranch(Greater, label 1); 

genExpr (nodeRIghtArg(n)); (* If the first one failed to decide, the val 
y of the 2nd is the value of the whole thing 


*) 


wrlteBranch(label2); 
wrIteLabeI(IabeII); 
wrIteBooI(nodeOp(n) * 


Or); (* write TRUE If OR. FALSE if AND *) 
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writeLabeI(Iabe12); 
END genLogicalOp; 


BEGIN 

END CodeGen. 

+++++++ 

Start CodeWrite.DEF 

+++++++ 

DEFINITION MODULE CodeWrite; 

(* This module outputs the code for the SIMPL compiler. *) 

FROM Symbol IMPORT symbol; 

FROM Token IMPORT tokenClass; 

EXPORT QUALIFIED writeLabeI. writeStringLabeI, wr i teRoutineLabeI, writeHalt, 
writeStringBranch, writeBranch, writeCondBranch. writePop, writeCall, 
writeWritelnt, writeReadlnt, writeReturn, writeFReturn, writeOp, 
writelnt, writeBool, writeSymbol, writeChar, 
wr1teWriteChar, writeReadChar; 


PROCEDURE writeLabeI(c:CARDINAL); 

(* Writes an "L" followed by the number, then a colon. *) 

PROCEDURE wrIteStringLabeI(s:ARRAY OF CHAR); 

(* Just writes the string followed by a colon. *) 

PROCEDURE writeRoutineLabeI(routineisymbol); 

(* Writes the name of the routine followed by a colon, and writes (on the 
screen) the procedure name so the user knows it's being compiled. *) 

PROCEDURE writeStringBranch(s: ARRAY OF CHAR); 

(* Write a branch followed by the string *) 

PROCEDURE writeCondBranch(tc:tokenCI ass; c:CARDINAL); 

(* Write a conditional branch (Equal, Greater or Less) followed by "L", then 
the number. *) 

PROCEDURE writeBranch(c:CARDINAL); 

(* Write an unconditional branch to the label. *) 

PROCEDURE writePop(s:symboI); 

(* Generate the appropriate pop instruction for the symbol *) 

PROCEDURE writeCalI(s:symbol); 

(* Generate a call instruction with the symbol *) 

PROCEDURE wrIteWritelnt; 

PROCEDURE writeReadlnt; 

PROCEDURE wrIteWrIteChar; 

PROCEDURE writeReadChar; 

(* instructions for I/O *) 

PROCEDURE wrIteReturn(numFormaIs:CARDINAL); 

PROCEDURE writeFReturn(numFormaIs:CARDINAL); 

(* Two types of return instructions; both take the number of formals as arg. 
*) 

PROCEDURE wrIteOp(tc:tokenCI ass); 

(* Write the instruction corresponding to the operator *) 

PROCEDURE writelnt(i;INTEGER); 

PROCEDURE writeBooI(b:BOOLEAN); 

PROCEDURE writeChar(c:CHAR); 

(* Write pushes for these constants. *) 

PROCEDURE writeSymboI(s:symboI); 

(* Generate the appropriate push instruction for the symbol *) 

PROCEDURE writeHalt; 


( continued ) 
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END CodeWrIte. 


+++++++ 

Start CodeWrite.MOD 
+++++++ 

IMPLEMENTATION MODULE CodeWrite: 

FROM InOut IMPORT WrlteStrlng, WrlteLn. Wrltelnt.WrlteCard; 

(* We can't use Write because of a conflict Inside t^^lass 
FROM Symbol IMPORT symboI, symbolstring, symboILexLeveI, symbolOffset; 
FROM SymboI Table IMPORT currentLexLevel; 

FROM Token IMPORT tokenClass. stringType; 

IMPORT MyTerminal; 

PROCEDURE wrtteStrtngLabel(s:ARRAY OF CHAR): 

BEGIN 

WrlteStrlng(s): 

WrIteStrIng(’: '); 

END wrIteStrIngLabeI: 

PROCEDURE wr11eRou11neLabeI(rout Ine:symboI); 

VAR nomerstringType; 

BEGIN / . t \ 
wr iteRoutlneName(routine); 

Wr iteString(*: '); 

WrlteLn; 

symboI Strlng(routine, name); 

MyTerminal.WriteStrIng(name); 

MyTerminaI.WriteLnString; 

END writeRoutineLabeI; 

PROCEDURE writeRoutineName(routine:symboI); 

VAR name:stringType; 

BEGIN x 

symboI String(routine, name); 

WrIteStrIng(name); 

IF symboILexLeveI(routine) <> 0 THEN 

WriteInt(symboIOffset(routine), 0); 

END; 

END writeRoutineName; 

PROCEDURE wr i teLabe I (c -.CARDINAL) ; 

BEGIN 

WriteChar(’L’): 

WriteCard(c, 0); 

WriteChar(*:*); 

Wr 1 teLn; 

END writeLabeI; 

PROCEDURE writeStringBranch(s:ARRAY OF CHAR); 

BEGIN 

wr iteOpCode('BRANCH ); 

Wr I teLnString(s): 

END writeStringBranch; 

PROCEDURE writeBranch(crCARDINAL): 

BEGIN 

wrIteOpCode(*BRANCH L ); 

WriteCard(c, 0); 

WriteLn; 

END writeBranch; 

PROCEDURE writeCondBranch(tc:tokenCI ass; c:CARDINAL); 

BEGIN 

CASE tc OF , , iN 

Equal: writeOpCodef'BREQL L ); 

I Less: writeOpCode(’BRLSS L’); 

Greater:writeOpCode(*BRGTR L*); 

ELSE 

MyTerminol.fataI(’wrIteCondBranch: unknown branch type’); 

END; 

WrIteCard(c, 0); 

WrlteLn; 

END writeCondBranch; 

PROCEDURE writeWritelnt; 
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BEGIN 

wr iteOpCode('WRINT*); 

Wr iteLn; 

END writeWritelnt; 

PROCEDURE writeReadlnt; 

BEGIN 

writeOpCode('RDINT'); 

Wr IteLn; 

END writeReadlnt; 

PROCEDURE writeWriteChar; 

BEGIN 

wr it eOpCode(* WRCHAR *); 

Wr iteLn; 

END wr iteWriteChar; 

PROCEDURE writeReadChar; 

BEGIN 

wr iteOpCode('RDCHAR'); 

Wr i teLn; 

END writeReadChar; 

PROCEDURE writeHalt; 

BEGIN 

wr 1teOpCode('HALT*); 

Wr iteLn; 

END writeHaIt; 

PROCEDURE writeReturn(numFormaIs:CARDINAL); 

BEGIN 

writeOpCode(’RETURN ’); 

WriteCard(numFormaI 8, 0); 

WriteLn; 

END wr1teReturn; 

PROCEDURE writeFReturn(numFormaIs:CARDINAL); 

BEGIN 

wr IteOpCode('FRETURN '); 

WrlteCard(numFormaIs, 0); 

Wr iteLn; 

END writeFReturn; 

PROCEDURE writelnt(i:INTEGER); 

BEGIN 

writeOpCode('PUSHC ’); 

Writelnt(i, 0); 

Wr iteLn; 

END writelnt; 

PROCEDURE wri teChar(c:CHAR); 

BEGIN 

wr iteOpCode('PUSHC '); 

WriteCharf.); 

Wr 1 teChar(c); 

Wr iteLn; 

END writeChar; 

PROCEDURE writeBooI(b:BOOLEAN); 

BEGIN 

IF b THEN 

wrltelnt(l); 

ELSE 

wr i telnt(0); 

END; 

END writeBooI; 

PROCEDURE wr1tePop(s:symboI); 

BEGIN 

wrlteSymAddr(s, 'POPC \ ’POPL *); 

END wr1tePop; 

PROCEDURE writeCalI(s:symbol); 

BEGIN 

writeOpCode("CALL M ); 

(continued) 
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writeRoutineName(s); 

WriteString(", "); 

WrI taint(currentLexLeveI() - symboILaxLavaI(s), 0); 
WrItaLn; 

END wrItaColI; 


PROCEDURE writaSymboI(s:symboI); 

BEGIN 

wr1taSymAddr(s, "PUSH \ "PUSHL "); 

END writaSymboI; 

PROCEDURE wrItaSymAddr(s:symboI; global, local:ARRAY OF CHAR); 
VAR nama:strIngTypa; 

BEGIN 

IF symboILaxLavaI(s) * 0 THEN (* global variable *) 

symboI String(s, name); 
writeOpCode(globaI); 

WrIteLnString(name); 

ELSE 

wr IteOpCode(locaI); 

Wr i taint(currentLexLeveI() - symboILexLeveI(s), 0); 
WriteStringC, ’); 

WrItelnt(symbol0ffset(s), 0); 
symbolString(s, name); 
wr i teComment(name); 

END; 

END writaSymAddr; 


PROCEDURE wrIteOp(tc:tokenCI ass); 
BEGIN 

CASE tc OF 


Plus: 

writeOpCode(’ADD’); 

Minus: 

writeOpCode(’SUB’); 

UMinus: 

wr iteOpCode(’NEG*); 

Times: 

writeOpCode(’MUL'); 

Divide: 

writeOpCode(’DIV’); 

Not: 

writeOpCodef’NOT'); 

Equal: 

wrlteOpCode(’EQUAL'); 

Greater: 

writeOpCode(’GREATER’); 

Less: 

writeOpCodef’LESS’); 

NotEqual: 

writeOpCode(’NOTEQL *); 

LessEqua1: 

writeOpCode('LSSEQL*); 

GreaterEqua1 

: writeOpCode(’GTREQL’); 

ELSE MyTermina1. 

fata 1("wr1teOp: unknown operator 


END; 


Wr iteLn; 
END writeOp; 


); 


PROCEDURE WriteLnString(s:ARRAY OF CHAR); 
BEGIN 

Wr 1 teString(s); 

Wr i teLn; 

END WriteLnString; 


PROCEDURE WriteChor(c:CHAR); 

(* can’t use InOut.Write, because the name conflicts with the Write in 
tokenClass. *) 

VAR s:ARRAY[0..1J OF CHAR; 

BEGIN 


5 L I J . , 

WriteString(s); 
END WriteChar; 


PROCEDURE writeOpCode(s:ARRAY OF CHAR); 
BEGIN 

WriteString(" "); 

WriteStrlng(s); 

END writeOpCode; 

PROCEDURE writeComment(s:ARRAY OF CHAR); 
BEGIN 

Wr iteStringf" ; "); 

WriteString(s); 

Wr iteLn; 

END writeComment; 
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BEGIN 

END CodeWrite. 

+++++♦+ 

Start Comp 1 ler.MOD 
++♦++++ 

MODULE Comp Iler; 

(* A compiler for the SIMPL programming language. 

Copyright 1985 By Jonathan Amsterdam. 

See the BYTE article "A SIMPL Compiler" for more information. 


Module map, roughly in order of low to high level: 


CharStuff 
StrlngStuff 
previous 

MyTermina1 
LexAnStuff 

Low-level character utilities \ 

Low-level string utilities 

Low-level terminal I/O utilities | 

Toolkit for building lexical analyzers / 

used in 

projects 

Token 

Symbo1 

Node 

Token, tokenList and typeType data types 
Symbol, symbolLlst and related data types 
Node and related data types 


TypeChecker 

LexAn 

Symbo1 Tab 1e 

CodeWrite 

CodeGen 

Procedures to do type-checking 

Lexical analyzer for compiler 

Compiler symbol table 

Actual output of code 

Code generation 


ExprParser 
Routines 
Parser 

Parses expressions 

Parses procedure and function declarations 
Main parser 



The module Debug, also supplied, is not used by the compiler, but contains 
routines useful in debugging the compiler. 

I would appreciate hearing about any bugs in the code. My BIX address is 
jba. —Jonathan Amsterdam 

*) 

FROM InOut IMPORT Openlnput, OpenOutput, Closelnput, CloseOutput; 

FROM MyTerminal IMPORT ClearScreen, pause, WriteLnString; 

FROM Parser IMPORT program; 


BEGIN 

ClearScreen; 

WriteLnStrIng("SIMPL Compiler VI.0"); 

Openlnput(’SMP’); 

OpenOutput(’ASM'); 

program; 

Closelnput; 

CloseOutput; 
pause('Done—*); 

END Compiler. 

+++++++ 

Start ExprParser.DEF 
+++++++ 

DEFINITION MODULE ExprParser; 

(* The part of the parser that handles expressions. 

Syntax: 

<expr>::* <expr>|<relexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> 
<relexpr> ::■ <intexpr> | <lntexpr> <relation> <intexpr> 

<intexpr> ::- <term> | <term> + <intexpr> | <term> - <intexpr> 

<term> ::- <factor> | <factor> * <term> | <factor> / <term> 

<factor> <ld> | <number> | <ca11> | <char> 

- <factor> | NOT <factor> | ( <expr> ) 

*) 

FROM Node IMPORT node; 


(continued) 
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EXPORT QUALIFIED expr; 

PROCEDURE expr():node; 

END ExprParser. 

+++++++ 

Start ExprParser.MOD 
++♦++++ 

IMPLEMENTATION MODULE ExprParser; 

(* Handles parsing of expressions, which are tricky because we have to 

make the operators left-associative, whereas the normal recursive descent 
grammar would have them be right-associative. 

The problem is that the trees are build from the right. To make 
them get built from the left, we pass to expr, relexpr, intexpr and term 
the partial tree constructed from the left, and each of these procedures 
hooks that tree on to the one It parses in the appropriate way. *) 

FROM Token IMPORT token, tokenClass, IsRelation; 

FROM LexAn IMPORT getToken, ungetToken, tokenErrorCheck. compError; 

FROM Symbol IMPORT symbol, SymbolClass. symbo1C IassEquaI; 

FROM SymboI Table IMPORT findSymbol; 

FROM Node IMPORT node, emptyNode, makeOpNode, makeUnopNode, makelntegerNode, 
makeBooleanNode, makeSymbolNode, makeCaI INode, makeStringNode, nodeEmpty, 
makeCharNode; 

FROM Parser IMPORT actuals; 

CONST dummy « Period; 

(* <expr>::- <expr>|<relexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> *) 
PROCEDURE expr()inode; 

BEGIN 

RETURN expr1(emptyNode, dummy); 

END expr; 

PROCEDURE expr1(I eft inode; opitokenClass)inode; 

VAR ninode; 

titoken; 

BEGIN 

n :« relexpr(); 
getToken(t); 

IF (t.class « And) OR (t.class ■ Or) THEN 

RETURN expr1(bulldTree(op, left, n), t.class); 

ELSE 

ungetToken; 

IF nodeEmpty(Ieft) THEN 
RETURN n; 

ELSE 

RETURN makeOpNode(op, left, n); 

END; 

END; 

END exprl; 

(* <reIexpr> <tntexpr> | <intexpr> <relation> <intexpr> *) 

PROCEDURE re Iexpr()inode; 

(* Here we don't have to worry about associativity since relations aren't 
associativel *) 

VAR ninode; 

titoken; 

BEGIN 

n i« intexpr(emptyNode, dummy); 
getToken(t); 

IF IsRelation(t.class) THEN 

RETURN makeOpNode(t.class, n, intexpr(emptyNode, dummy)); 

ELSE 

ungetToken; 

RETURN n; 

END; 

END relexpr; 

(* <!ntexpr> <term> | <term> + <intexpr> | <term> - <intexpr> *) 
PROCEDURE intexpr(left inode; op:tokenClass)inode; 

VAR n:node; 
titoken; 
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BEGIN 

n :« term(emptyNode, dummy); 
getToken(t); 

IF (t.class « Plus) OR (t.class « Minus) THEN 

RETURN intexpr(buildTree(op, left, n), t.class); 

ELSE 

ungetToken; 

IF nodeEmpty(left) THEN 
RETURN n; 

ELSE 

RETURN makeOpNode(op, left, n); 

END; 

END; 

END Intexpr; 

(* <term> ;<factor> | <factor> * <term> | <factor> / <term> *) 

PROCEDURE term(I eft mode; op:tokenClass):node; 

VAR n:node; 

t:token; 

BEGIN 

n :* factor(); 
getToken(t); 

IF (t.class ** Times) OR (t.class « Divide) THEN 
RETURN term(buildTree(op, left, n), t.class); 

ELSE 

ungetToken; 

IF nodeEmpty(left) THEN 
RETURN n; 

ELSE 

RETURN makeOpNode(op, left, n); 

END; 

END; 

END term; 

(* <factor> <id> | <number> | <caI I> | <char> | - <factor> | NOT <factor> 

( <«xpr> ) *) 

PROCEDURE factor():nod«; 

VAR ninode; 

trtoken; 

BEGIN 

getToken(t); 

CASE t.cl ass OF 

Int: RETURN makeIntegerNode(t.integer); 

Character: RETURN makeCharNode(t.ch); 

String: RETURN makeStringNode(t.string); 

Minus: RETURN makeUnopNode(UMinus, factor()); 

Not: RETURN makeUnopNode(Not, factor()); 

True: RETURN makeBooIeanNode(TRUE); 

False: RETURN makeBooIeanNode(FALSE); 

Lparen: 

n :- expr(); 

tokenErrorCheck(Rparen, ’Right paren expeced'); 

RETURN n; 

| Identifier: RETURN callOrld(t); 

ELSE 

compError(’bad factor’); 

RETURN emptyNode; 

END; 

END factor; 

PROCEDURE calI0rld(t:token):node; 

VAR sisymboI; 

BEGIN 

8 :- findSymbol(t.string); 

IF symbolClassEqual(s, Func) THEN 

RETURN makeCaI INode(s, actuals()); 

ELSIF symboICIassEquaI(s, Proc) THEN 

compError(’procedures cannot be used in an expression'); 

RETURN emptyNode; 

ELSE (* it’s a variable *) 

RETURN makeSymboINode(s); 

END; 

END callOrld; 


[continued) 
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PROCEDURE billldTree(op:tokenClass; nl, n2:node):node; 

(* This Is the key hack that builds trees up from the left if necessary. *) 
BEGIN 

IF nodeEmpty(n1) THEN 
RETURN n2; 

ELSE 

RETURN makeOpNode(op, nl, n2); 

END; 

END bulIdTree; 

BEGIN 

END ExprParser. 

+++++++ 

Start LexAn.DEF 
+++++++ 

DEFINITION MODULE LexAn; 

(* The lexical analyzer for the SIMPL compiler. It uses the InOut module 
do Input, so you can get input from a file by redirecting it with 
InOut.Openlnput. 

This module also handles errors. *) 

FROM Token IMPORT token, tokenClass; 

EXPORT QUALIFIED getToken, ungetToken, getTokenCI ass, tokenErrorCheck, 
getTokenErrorCheck, errorFlag, compError, peekTokenCI ass; 

VAR errorFIag:BOOLEAN; (* Set to TRUE when an error occurs. *) 

PROCEDURE getToken(VAR t:token); 

(* Get a token from the input stream. *) 

PROCEDURE ungetToken; 

(* Push a token back on the input stream. Can only unget one at a time. *) 
PROCEDURE getTokenCIass():tokenClass; 

(* Get a token from the input stream, but Just return its class. *) 

PROCEDURE peekTokenCI ass():tokenCI ass; 

(* Get a token from the input stream, unget it, and return its class. *) 

PROCEDURE tokenErrorCheck(tc:tokenClass; msg: ARRAY OF CHAR); 

(* Read a token from the input stream and compare its class to tc. If they 
are the same, do nothing. If they are different, write the current line 
to the screen, print the message and unget the token. *) 

PROCEDURE getTokenErrorCheck(VAR trtoken; tc:tokenCI ass; msg: ARRAY OF CHAR); 
(* Like tokenErrorCheck. but returns the token as well. *) 

PROCEDURE compError(msg:ARRAY OF CHAR); 

(* Writes the current line and displays msg. Sets errorFlag to TRUE. *) 

END LexAn. 

+++++++ 

Start Lexan.MOD 
+++++++ 

IMPLEMENTATION MODULE LexAn; 

(* Lexical analyzer for the SIMPL compiler. Uses the routines in 
LexAnStuff.*) 

FROM InOut IMPORT EOL; 

FROM Token IMPORT token, tokenClass; 

FROM MyTerminal IMPORT fatal, WriteLnString; 

FROM StringStuff IMPORT stringLen; 

FROM Symbol Table IMPORT enterKeyword, findKeyword; 

FROM LexAnStuff IMPORT dispatch, enterAII, enterChar, enterEndOfFiIe, ignore, 
enterAlphas, enterDigits, skipToChar, a IphaNumString, poslnteger, string, 
enterWhite, writeLine, getChar, ungetChar; 

VAR tok: token; 

ungotten: BOOLEAN; 
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PROCEDURE getToken(VAR t:token); 

BEGIN 

getTok; 
t := tok; 

END getToken; 

PROCEDURE getTok; 

VAR c:CHAR; 

BEGIN 

IF ungotten THEN 

ungotten := FALSE; 

ELSE 

dispatch; 

END; 

END getTok; 

PROCEDURE ungetToken; 

BEGIN 

IF ungotten THEN 

fata I("ungetToken: can only unget one token at a time"); 

ELSE 

ungotten := TRUE; 

END; 

END ungetToken; 

PROCEDURE getTokenCI ass():tokenClass; 

BEGIN 

getTok; 

RETURN tok.cI ass; 

END getTokenCIass; 

PROCEDURE peekTokenCIass():tokenCI ass; 

BEGIN 

getTok; 
ungetToken; 

RETURN tok.cl ass; 

END peekTokenCIass; 

PROCEDURE tokenErrorCheck(tc:tokenCI ass; msg: ARRAY OF CHAR); 

BEGIN 

getTok; 

IF tok.class <> tc THEN 
compError(msg); 

IF tok.class * EndOflnput THEN 

fata I("unexpected end of input"); 

END; 

ungetToken; 

END; 

END tokenErrorCheck; 

PROCEDURE getTokenErrorCheck(VAR titoken; tc:tokenClass; msg: ARRAY OF CHAR); 
BEGIN 

tokenErrorCheck(tc, msg); 
t := tok; 

END getTokenErrorCheck; 

(*** reading procedures ★**) 

PROCEDURE iI IegaIChar(c:CHAR); 

VAR charstrlng:ARRAY[0..1] OF CHAR; 

BEGIN 

charstringT01 :* c; (* fake a 1-char string *) 

charstring[1] :• 0C; 

compError(*iI IegaI character*); 

getTok; 

END iIlegalChar; 


PROCEDURE comment(c:CHAR); (* Comments are ignored. They are delimited 

by { and } *) 

BEGIN 

skIpToChar(*|*); 
getTok; 

END comment; 


(continued) 
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PROCEDURE 1dOrKeyword(c:CHAR); 

(* Get an alphanumeric string from the Input. If we find It In the symbol 

table marked as a keyword, then It’s a keyword; findKeyword will have taken 
care of setting tok.class to the right value. Else, it's an identifier. *) 
BEGIN 

IF NOT a IphaNumString(c, tok.string} THEN 
compError(*identifier too long*); 

END; 

IF NOT findKeyword(tok.string, tok.class) THEN 
tok.class :■ Identifier; 

END; 

END idOrKeyword; 

PROCEDURE poslnt(c:CHAR); 

BEGIN 

tok.class :« Int; 

tok.Integer :* poslnteger(c); 

END poslnt; 

PROCEDURE charProc(c:CHAR); 

(* Read a character, delimited by delim, from the input. Can use 
backslash: \n * newline, \t ■ tab, anything else literal. *) 

BEGIN 

tok.class :■ Character; 

IF (NOT str I na(c, tok.string)) OR (stringLen(tok.string) > 1) THEN 
compError(* I I IegaI character constant*); 

END; 

tok.ch tok.string[0]; 

END charProc; 


PROCEDURE stringProc(c:CHAR); 

(* Read a string from the input. If too long, skip to the next delim. *) 
BEGIN 

tok.class := String; 

IF NOT strlngfc, tok.string) THEN 
compError(*string too long*); 
skipToChar(c); 

c getChar(); (* get the delimiter *) 

END; 

END stringProc; 


(*** Reading special characters ***) 


PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 


period(c:CHAR); 
semicoI on(c:CHAR) 
equal(c:CHAR); 
comma(c:CHAR); 
plus(c:CHAR); 
minus(c:CHAR); 
times(c:CHAR); 
dividefc:CHAR); 

Iparen(crCHAR); 
rparen(c:CHAR); 


BEGIN tok.class 
;BEGIN tok.class 
BEGIN tok.class 
BEGIN tok.class 
BEGIN tok.class 
BEGIN tok.class 
BEGIN tok.class 
BEGIN tok.class 
BEGIN tok.cl ass 
BEGIN tok.class 


:= Period; 

:= Semicolon; 
:* EquaI; 

:» Comma; 

:= Plus; 

:= Minus; 

:= Times; 

:= Divide; 

:*= Lparen; 

:= Rparen; 


PROCEDURE greater(c:CHAR); 

BEGIN 

IF getChar() - *»* THEN 

tok.class :* GreaterEquaI; 

ELSE 

ungetChar; 

tok.cI ass :* Greater; 

END; 

END greater; 


PROCEDURE I ess(c:CHAR); 
BEGIN 

c :* getChar(); 

IF c » ’-* THEN 


tok.c1 ass 

:« LessEqual 

ELSIF c * *>* 

THEN 

tok.c1 ass 

:= NotEqua1; 

ELSE 


ungetChar; 
tok.c1 ass 

i 

:« Less; 

END; 


END less; 



END period; 

END semicolon; 
END equaI; 

END comma; 

END plus; 

END minus; 

END times; 

END divide; 

END lparen; 
END rparen; 
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PROCEDURE colon(c:CHAR); 

BEGIN 

IF getChar() - THEN 

tok.class :* Assignment; 

ELSE 

ungetChar; 

tok.class :» Colon; 

END; 

END colon; 

PROCEDURE endOfInput(c:CHAR); 
BEGIN 

tok.class :* EndOflnput; 

END endOflnput; 


(*** Initialization of charTable ***) 


PROCEDURE initCharTabIe; 

BEGIN 

enterAI I(iI IegaI Char); 
enterWhite(ignore); 
enterAIphasSidOrKeyword); 
enterDigits(poslnt); 
enterCharS’.*, period); 
enterChar(’:*, colon); 
enterChar S*; *, 
enterChar( 1 (*, 
enterChar(*)*, 
enterChar(•,*, 
enterChar 


semicolon); 

Iparen); 
rparen); 
comma); 
equaI); 

enterChar(’>’, greater); 
enterCharS*<’, less); 
enterCharS’ + ', plus); 
enterCharS, minus); 
enterCharS’*', times); 

enterChar(V*• divide); 

enterCharS'\' , comment); 
enterCharS "", stringProc); 
enterChar("•", charProc); 
enterEndOfFlIe(endOfInput); 
END initCharTobIe; 


PROCEDURE enterKeywords; 

BEGIN 

enterKeyword(*AND*, And); 
enterKeywordS'BEGIN*, Begin); 
enterKeywords’BOOLEAN*, Boo Iean); 
enterKeywordS’CHAR', Char); 
enterKeywords’DO’, Do); 
enterKeywordS’ELSE*, Else); 
enterKeywords’ELSIF', Elsif); 
enterKeywordS’END’, End); 
enterKeywords’FALSE', False); 
enterKeywordf’FUNCTION’, Function); 
enterKeywords'IF’, If); 
enterKeywordS * INTEGER*, Integer); 
enterKeywordC’NOT*, Not); 
enterKeywords’OR’, Or); 
enterKeywords'PROCEDURE’, Procedure); 
enterKeywords’PROGRAM*, Program); 
enterKeywords’READ’, Read); 
enterKeywordS’RETURN’, Return); 
enterKeywords’THEN*, Then); 
enterKeywordS’TRUE’, True); 
enterKeywords’VAR*, Var); 
enterKeywords’WHILE’, While); 
enterKeywords’WRITE*, Write); 

END enterKeywords; 

(*** errors ***) 

PROCEDURE compError(msg:ARRAY OF CHAR); 

BEGIN 

wr1teL1ne; 

Wr1teLnString(msg); 

(< continued) 
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errorFlag :■ TRUE; 
END compError; 

BEGIN 

ungotten :■ FALSE; 
errorFlag FALSE; 
InltCharTable; 
enterKeywords; 

END LexAn. 


+++++++ 

Start Node.DEF 

+++++++ 

DEFINITION MODULE Node; 

(* Nodes are what make up the parse tree produced by the SIMPL parser. 

They consist of all data relevant to generating code. *) 

FROM Token IMPORT tokenClass, typeType; 

FROM Symbol IMPORT symbol; 

EXPORT QUALIFIED node, nodeClass, NodeClass, emptyNode, nodeEmpty, freeNode, 
makeStmtsNode, makelfNode, makeWhiIeNode, makeReturnNode, 
makeAssignmentNode, makeExprLIstNode, makeOpNode, makeUnopNode, 
makelntegerNode, makeBooIeanNode, makeSymboI Node, makeCaI I Node, 
makeWriteNode, makeReadNode, makeStringNode, makeCharNode, 
nodeFIrst, nodeRest, nodeTest, nodeThen, nodeElse, nodeStmts, nodeRHS, 
nodeLHS, nodeArgs, nodeRoutine, nodeExpr, nodeArg, nodeLeftArg, 
nodeRightArg, nodeOp, nodeSymbol, nodeType, nodelnt. nodeBool, 
nodeNumFormaIs, nodeString, nodeChar; 


TYPE 

NodeClass * (* 

(nOp, 

*) 

nUnop, 
nBooI , 
nlnt, 
nChar, 
nString, 
nSymboI, 
nlf, 
nWhiIe, 
nReturn, 
nCaI I, 

nAssignment, 
nWrlte, nRead, 
nList); 

node; 

VAR emptyNode: node; 

PROCEDURE nodeCI ass(n:node):NodeClass; 

(* Returns the class of node *) 

PROCEDURE nodeEmpty(n:node)-.BOOLEAN; 

(* Returns true if node is the emptyNode *) 

PROCEDURE freeNode(n:node); 

(* Frees the storage associated with n *) 

(*** Node creation ***) 

PROCEDURE makeStmtsNode(f1rst, rest:node):node; 

(* Make a node representing a list of statements *) 

PROCEDURE makeReturnNode(routine:symbol; returnExpr:node):node; 

(* Make a return node. Routine is the routine we are returning from. 

returnExpr is an expression to be returned, for functions; for procedures, 
it should be the empty node. *) 

PROCEDURE makeCaI I Node(name:symboI; actuals:node):node; 

PROCEDURE makeWrIteNode(actuaIs:node):node; 

PROCEDURE makeReadNode(actuaIs:node):node; 

(* In all of these, actuals should have been made with makeExprListNode. *) 


different kinds of nodes *) 

(* binary operators (+, -, *, /, relations, AND, OR) 

I * unary operators (unary minus, NOT) *) 

♦ a boolean constant (TRUE, FALSE) *) 

* an integer constant *) 

* a character constant *) 

* a string constant *) 

♦ a symbol (variable) *) 

* IF statement *) 

* WHILE statement *) 

* RETURN statement, either procedure or function *) 
* procedure call (statement) or function call *) 

! * assignment statement *) 

* WRITE and READ statements *) 

(* a list of statements or expressions *) 
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PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 


makelfNode(test, then, e I se mode) mode; 

makeWhileNode(test, stmts:node)mode; 

makeAssignmentNode(var :symboI; expr mode)mode; 

makeExprListNode(first, rest mode)mode; 

makeOpNode(op;tokenCIass; leftarg, r i ghtarg mode) mode; 

makeUnopNode(op: tokenCI ass; argmode) mode; 

makeIntegerNode(I:INTEGER):node; 

makeBooIeanNode(b:BOOLEAN)mode; 

makeSymboINode(idisymbol):node; 

makeStrIngNode(s;ARRAY OF CHAR)mode; 

makeCharNode(c:CHAR)mode; 


(*** Accessing parts of nodes **) 

(* many nodes have a type associated with them *) 
PROCEDURE nodeType(nmode):typeType; 


(* for constants *) 

PROCEDURE nodelnt(n:node):INTEGER; 

PROCEDURE nodeBooI(n mode):BOOLEAN; 

PROCEDURE nodeChar(nmode):CHAR; 

PROCEDURE nodeString(n:node; VAR s:ARRAY OF CHAR); 
(* Just truncates is s is too short. *) 


(* for 11sts *) 

PROCEDURE nodeF i rst (n mode) mode; 
PROCEDURE nodeRest (n mode) mode; 

(* for IF statements *) 

PROCEDURE nodeTest (n mode) mode; 
PROCEDURE nodeThen(nmode) mode; 
PROCEDURE nodeEIse(nmode)mode; 

(* for WHILE statements *) 

PROCEDURE nodeStmts(nmode) mode; 

(* for assignment statements *) 
PROCEDURE nodeRHSfn mode) mode; 
PROCEDURE nodeLHS(nmode):symboI; 

(* for calls *) 

PROCEDURE nodeArgs(n:node):node; 
PROCEDURE nodeRout ine(nmode) isymbol; 


(* also for WHILE statements *) 


* right-hand side *) 

* left-hand side *) 


(* for RETURN statements *) 

PROCEDURE nodeExpr(n:node):node; 

PROCEDURE nodeNumFormaIs(n;node):CARDINAL; 


(* for ops and unops *) 

PROCEDURE nodeArg(nmode)mode; 
PROCEDURE nodeLeftArg(nmode)mode; 
PROCEDURE nodeRightArg(nmode)mode; 
PROCEDURE nodeOp(n;node):tokenClass; 

(* for symbols *) 

PROCEDURE nodeSymbol(nmode):symboI; 
END Node. 


+++++++ 

Start Node.MOD 
+++++++ 

IMPLEMENTATION MODULE Node; 

(* Procedures for constructing and manipulating the nodes of the parse tree. 

Most type-checking is done here. *) 

FROM Token IMPORT tokenClass, typeType, stringType, isRelation; 

FROM Symbol IMPORT symbol, Symbo1C I ass, symboI Type, emptySymbol, numFormals; 
FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM TypeChecker IMPORT typeCompatibIe, opAppropriate, callCheck, unopCheck, 
readCheck, wrlteCheck, binopCheck, returnCheck, assignCheck; 

FROM MyTermlnal IMPORT Wr1teString, fatal; 

FROM StringStuff IMPORT stringCopy; 


( continued ) 
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TYPE 

node ■ POINTER TO nodeRec; 
nodeRec ■ RECORD 

type: typeType; 

CASE clas8:NodeCloss OF 

nOp: op: tokenClase; leftArg, rlghtArg: node; 

nUnop: unop: tokenClase; arg: node; 

nBool: bool: BOOLEAN; 

nlnt: Int: INTEGER; 

nChar: ch: CHAR; 

nStrIng: str lng:strIngType; 

nSymbol: eym: symbol; 

nlf: test, then, else: node; 

nWhlle: wtest, stmts: node; 

nAssignment: LHS: symbol; RHS:node; 

nCall, nWrlte, nRead: rout Ine:symboI; args:node; 

nReturn: nFormaIs:CARDINAL; expr:node; 

nLlst: first, rest:node; 

END; 

END; 


PROCEDURE nodeCloss(n:node):NodeClass; 

BEGIN 

RETURN n^.class; 

END nodeClass; 

PROCEDURE nodeEmpty(n:node):BOOLEAN; 

BEGIN 

RETURN n « emptyNode; 

END nodeEmpty; 

PROCEDURE freeNode(n:node); 

BEGIN 

IF n <> emptyNode THEN 

WITH n* DO CASE class OF 

nlnt, nBool, nSymbol, nString, nChor: (* do nothing *); 
| nOp: freeNode(leftArg); 

freeNode(rIghtArg); 
nUnop: freeNodefarg); 

nlf: freeNodeitest); 

freeNodefthen); 
freeNode(eIse); 

| nWhlle: freeNodefwtest); 

freeNode(stmts); 
nAssIgnment: freeNode(RHS); 
nCall, nRead, nWrite: freeNode(args); 
nReturn:freeNodefexpr); 
nLlst: freeNode(fIrst); 

freeNode(rest); 

ELSE 

WrIteString("freeNode: unknown node type"); 

END; END; 

DISPOSE(n); (* , n".class); *) 

END; 

END freeNode; 


(*** node creation ***) 

PROCEDURE makeStmtsNode(fIrst, rest:node):node; 

VAR n:node; 

BEGIN 

n :* newNode(nLlst); 
n^.first :- first; 
n^.rest :- rest; 

RETURN n; 

END makeStmtsNode; 

PROCEDURE makeExprListNode(first, rest:node):node; 
VAR n:node; 

BEGIN 

n :* newNode(nLIst); 
n^.f1rst :* first; 
n^.rest :- rest; 

RETURN n; 

END makeExprLIstNode; 
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PROCEDURE makeIfNode(test, then, else:node):node; 

VAR n:node; 

BEGIN 

n i® newNode(nIf); 
n^.test i« test; 
n^.then ;* then; 
n^.else i« else; 

RETURN n; 

END makelfNode; 

PROCEDURE makeWhIIeNode(test, stmts:node):node; 

VAR n:node; 

BEGIN 

n ;* newNode(nWhiIe); 
n^.wtest ;* test; 
n A .stmts ;■ stmts; 

RETURN n; 

END makeWhIIeNode; 

PROCEDURE makeReturnNode(routIne:symboI; returnExpr:node):node; 

VAR ninode; 

BEGIN 

n ;« newNode(nReturn); 
n^.expr :® returnExpr; 

IF returnCheck(routIne, returnExpr) THEN 
n^.nFormals i® numFormaIs(routIne); 

END; 

RETURN n; 

END makeReturnNode; 

PROCEDURE makeAssIgnmentNode(var:symboI; exprinode)inode; 

VAR ninode; 

BEGIN 

n i* newNode(nAssignment); 
n^.LHS i® var; 
n^.RHS i® expr; 
assignCheck(var, expr); 

RETURN n; 

END makeAssignmentNode; 

PROCEDURE makeOpNode(opitokenClass; leftarg, rightarginode)inode; 

VAR ninode; 

typeOKiBOOLEAN; 

BEGIN 

n i® newNode(nOp); 
n*.op i® op; 
n^.leftArg i* leftarg; 
n^.rlghtArg i® rlghtarg; 

typeOK i® blnopCheck(op, leftarg, rlghtarg); 

IF isReI atlon(op) THEN 
n^.type ;® tBoolean; 

ELSIF typeOK THEN 

n^.type i® leftarg^.type; 

ELSE 

n^.type i« tUnknown; 

END; 

RETURN n; 

END makeOpNode; 

PROCEDURE makeUnopNode(op;tokenClass; arg;node);node; 

VAR ninode; 

BEGIN 

n i® newNode(nUnop); 
n^.unop i® op; 
n^.arg :■ arg; 

IF unopCheck(op, arg) THEN 
n^.type ;® arg A .type; 

ELSE 

n^.type ;■ tUnknown; 

END; 

RETURN n; 

END makeUnopNode; 

PROCEDURE makeIntegerNode(I:INTEGER)inode; 

VAR ninode; 

(continued) 
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BEGIN 

n :* newNode(nInt); 
n*.type :» tlnteger; 
n^.int I; 

RETURN n; 

END mokelntegerNode; 

PROCEDURE makeBooIeanNode(b:BOOLEAN):node; 

VAR n:node; 

BEGIN 

n :■ newNode(nBooI); 
n^.type :« tBoolean; 
n^.bool :« b; 

RETURN n; 

END makeBooIeanNode; 

PROCEDURE makeCharNode(c:CHAR):node; 

VAR n:node; 

BEGIN 

n :* newNode(nChar); 
n^.type :■ tChar; 
n^.ch :■ c; 

RETURN n; 

END makeCharNode; 

PROCEDURE makeSymboI Node(s:symboI)inode; 

VAR n:node; 

BEGIN 

n :■ newNode(nSymboI); 
n^.type symboIType(s); 
n^.sym :■ s; 

RETURN n; 

END makeSymboI Node; 

PROCEDURE makeCal INode(name:symbo I ; actuaI s inode) -.node 
VAR n:node; 

BEGIN 

n :* newNode(nCaI I); 

WITH n~ DO 

routine name; 

args :■ actuals; 

type :* symboIType(name}; 

calICheck(routine, args); 

END; 

RETURN n; 

END makeCalINode; 

PROCEDURE makeWrlteNode(actuaIs:node):node; 

VAR n:node; 

BEGIN 

wrIteCheck(actuaIs); 
n :■ newNode(nWrIte); 
n*.routine :* emptySymbol; 
n^.args :■ actuals; 

RETURN n; 

END makeWrIteNode; 

PROCEDURE makeReadNode(actuaIs:node):node; 

VAR n:node; 

BEGIN 

readCheck(actuals); 
n :* newNode(nRead); 
n*.routine :* emptySymbol; 
n^.args :* actuals; 

RETURN n; 

END makeReadNode; 

PROCEDURE makeStrIngNode(s:ARRAY OF CHAR):node; 

VAR n:node; 

BEGIN 

n :* newNode(nString); 
strlngCopy(n^.string, s); 

RETURN n; 

END makeStringNode; 

PROCEDURE newNode(nc:NodeCI ass):node; 
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VAR ninode; 

BEGIN 

NEW(n); (* nc); *) 
n~.class :« nc; 
n^.type :» tUnknown; 
RETURN n; 

END newNode; 


(*** node access ***) 

PROCEDURE nodelnt(nmode): INTEGER; 

BEGIN 

nodeCIassCheck('nodelnt*, n, nlnt); 

RETURN n^.Int; 

END nodelnt; 

PROCEDURE nodeBool (ninode)-.BOOLEAN; 

BEGIN 

nodeCIassCheck('nodeBooI', n, nBool); 

RETURN n^.bool; 

END nodeBool; 

PROCEDURE nodeChar(ninode)iCHAR; 

BEGIN 

nodeCIassCheck('nodeChar', n, nChar); 

RETURN n^.ch; 

END nodeChar; 

PROCEDURE nodeString(ninode; VAR siARRAY OF CHAR); 

BEGIN 

nodeCIassCheck('nodeString', n, nString); 
strIngCopy(s, n A .string); 

END nodeStrlng; 

PROCEDURE nodeFf rst(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeFirst', n, nLIst); 

RETURN n*.first; 

END nodeFirst; 

PROCEDURE nodeRest(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeRest', n, nLIst); 

RETURN n^.rest; 

END nodeRest; 

PROCEDURE nodeTest(ninode)inode; 

BEGIN 

IF n^.class ■ nlf THEN 
RETURN n*.test; 

ELSIF n A .class - nWhlle THEN 
RETURN n^.wtest; 

ELSE 

nodeCIassEr ror(*nodeTest') ; 

RETURN emptyNode; 

END; 

END nodeTest; 

PROCEDURE nodeThen(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeThen', n, nlf); 

RETURN n^.then; 

END nodeThen; 

PROCEDURE nodeElse(n;node)inode; 

BEGIN 

nodeCIassCheck('nodeEIse', n, nlf); 

RETURN n^.else; 

END nodeEIse; 

PROCEDURE nodeStmts(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeStmts’, n, nWhlle); 

RETURN n^.stmts; 

END nodeStmts; 

(continued) 
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PROCEDURE nodeRHS(n:node):node; 

BEGIN 

nodeCIassCheck(’nodeRHS’, n, nAssignment ); 

RETURN rT.RHS; 

END nodeRHS; 

PROCEDURE nodelHS(n:node):symbol; 

BEGIN 

nodeClassCheck(’nodeLHS’, n, nAssignment); 

RETURN n^.LHS; 

END nodeLHS; 

PROCEDURE nodeArgs(n:node):node; 

BEGIN 

WITH n* DO 

IF (class « nCall) OR (class = nRead) OR (class = nWrite) THEN 
RETURN args; 

ELSE 

nodeCIassError(’nodeArgs’); 

END; 

END; 

END nodeArgs; 

PROCEDURE nodeRoutIne(n:node):symboI; 

begin ^ . lN 

nodeCIassCheck( 1 nodeRoutine*, n, nCall); 

RETURN n*.routine; 

END nodeRoutine; 

PROCEDURE nodeExpr(n:node):node; 

begin ^ x x 

nodeCIassCheck(*nodeExpr 9 , n, nReturn); 

RETURN n^.expr; 

END nodeExpr; 

PROCEDURE nodeArg(n:node)inode; 

BEGIN 

nodeCIassCheck(*nodeArg*, n, nUnop); 

RETURN n^.arg; 

END nodeArg; 

PROCEDURE nodeLeftArg(ninode)inode; 

BEGIN ^ x 

nodeCIassCheck('nodeLeftArg*, n, nOp); 

RETURN n~.leftArg; 

END nodeLeftArg; 

PROCEDURE nodeRightArg(ninode)inode; 

BEGIN 

nodeClassCheck(*nodeRightArg', n. nOp); 

RETURN n^.rightArg; 

END nodeRightArg; 

PROCEDURE nodeOp(n;node);tokenCI ass; 

BEGIN 

IF n^.class = nOp THEN 
RETURN n^.op; 

ELSIF n*.class = nUnop THEN 
RETURN n^.unop; 

ELSE 

nodeCIassError(*nodeOp*); 

RETURN Plus; 

END; 

END nodeOp; 

PROCEDURE nodeSymbol(n;node)isymboI; 

BEGIN t BN 

nodeClassCheck(*nodeSymbol*, n, nSymbol); 

RETURN n^.sym; 

END nodeSymbol; 

PROCEDURE nodeNumFormaIs(ninode)iCARDINAL; 

begin ^ A N 

nodeCIassCheck(* nodeNumFormaIs*, n, nReturn); 

RETURN n^.nFormaIs; 

END nodeNumFormaIs; 
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PROCEDURE nodeType(ninode):typeType; 

BEGIN 

RETURN n^.type; 

END nodeType; 

(*** other ***) 

PROCEDURE nodeCIossCheck(s:ARRAY OF CHAR; ninode; nciNodeCIass); 

BEGIN 

IF n*.class <> nc THEN 
nodeCIassError(s); 

END; 

END nodeCIassCheck; 

PROCEDURE nodeCIassError(s:ARRAY OF CHAR); 

BEGIN 

Wr i teStrIng(s); 

fatal (": node of wrong type"); 

END nodeCIassError; 

BEGIN 

emptyNode := NIL; 

END Node. 

+++++++ 

Start Parser.DEF 
+++++++ 

DEFINITION MODULE Parser; 

(* This is the bulk of the SIMPL parser. It covers most of the language. 
For routines (procedures and functions) see Routines. 

For expressions, see ExprParser. 

Syntax handled by this module: 

<program> PROGRAM <id>; <vars> <routines> <block> . 

<vars> <empty> | VAR <varIist> 

<varlist> <decl> | <decl> <varlist> 

<decl> <idIist> : <type> ; 

<IdI 1st> <id> | <id> , <idIist> 

<type> INTEGER | BOOLEAN | CHAR 

<block> ::«= BEGIN <stmts> END 
<stmts> <empty> | <stmt> ; <stmts> 

<stmt> <while> | <if> | <return> | <assign> | <caI I> 

<while> WHILE <expr> DO <stmts> END 

<if> IF <eIsif> END 

<eIsif> <expr> THEN <stmts> <else> 

<else> <empty> | ELSIF <eIsif> | ELSE <stmts> 

<return> RETURN | RETURN <expr> 

<assign> <id> :* <expr> 

<call> <id> <actuals> 

<actuals> <empty> I ( <exprllst> ) 

<exprllst> :<expr> | <expr> , <exprlist> 

*) 

FROM Symbol IMPORT symbol; 

FROM Node IMPORT node; 

FROM Token IMPORT tokenList; 

EXPORT QUALIFIED program, vars, idlist, block, actuals; 

PROCEDURE program; 

(* Parse the entire program *) 

PROCEDURE vars(rout 1neName:symboI); 

(* Parse variable declarations. Scope indicates whether these are local 
or global variables. RoutineName is the name of the routine currently 
being compiled; if these are global variables, it should be the name of 
the program. *) 

PROCEDURE id I 1st():tokenList; 

(* Parse a list of identifiers *) 


{continued ) 
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PROCEDURE bIock(rout1ne:symboI ) inode; ]k \ 

(* Parse a block of code. Routine is the routine currently being compiled. *) 

PROCEDURE actuals():node; ., x . . v 

(* Parse a list of actual parameters, l.e. a list of expressions. ) 

END Parser. 

+++++++ 

Start Parser.MOD 
+++++++ 

IMPLEMENTATION MODULE Parser; 

(* Most of the parser for the SIMPL compiler. It Is o top-down, recursive 
descent parser. *) 

FROM Token IMPORT token, tokenCloss. isType, emptyTokenList, 

tIToken. tINext, tIEmpty, addToTokenList, tokenList, freeTokenList, 
typeType, tokenClassToType; c , r «r 

FROM LexAn IMPORT getToken. getTokenCIass, peekTokenCloss. compError, 
ungetToken. tokenErrorCheck. getTokenErrorCheck; 

FROM Symbol IMPORT symbol, emptySymbol, SymbolCloss. symbolEmpty, 
symbolClassEquol, symbolEqual; 

FROM SymboI Table IMPORT enterSymbol, enterLocal. enterFormal. findSymbol, 

FROM^ode" IMPORT node, emptyNode. makeStmtsNode, mokelfNode, makeWhiIeNode, 
makeReturnNode, makeAssignmentNode, makeExprListNode, 
makeCalINode. makeReodNode, mokeWrIteNode. nodeType; 

FROM CodeGen IMPORT genBlock, genGlobal; 

FROM CodeWrite IMPORT wrIteStringBranch. writeHalt, writeRoutineLabeI. 

FROM TypeChecker IMPORT boolCheck; 

FROM ExprPorser IMPORT expr; 

FROM Routines IMPORT routines; 

FROM MyTermInal IMPORT fatal; 

VAR programName:symboI; 

(♦ <program> PROGRAM <ld>; <vars> <routlnes> <block> . *) 

PROCEDURE program; 

VAR t:token; 
n:node; 

B ^ ( ^ 1 tokenErrorCheck (Prog ram. ’keyword "PROGRAM" expected’); 

getTokenErrorCheck(t , Identifier, name of program expected ), 

IF t t?stHng > := d "???"; er (* H ^ the program name isn’t given, make one up *) 

programName := enterSymbol(t.string. Proc, tUnknown); 
writeStringBranch(t.string); 

tokenErrorCheck (Semi co I on, ’semicolon expected ), 

vars(emptySymboI); 

routines; 

wrIteRoutineLabeI(programName); 
genBIock(block(programName)); 
tokenErrorCheck(Period, ’period expected ); 
tokenErrorCheck(EndOfInput, ’end of input expected ). 
writeHalt; 

END program; 

(*** variable declarations ***) 

(* <vars> <empty> | VAR <varlist> *) 

PROCEDURE vars(routineName:symbol); 

BEGIN 

IF getTokenCIass() = Var THEN 
varIist(routineName); 

ELSE 

ungetToken; 

END; 

END vars; 

<varlist> <decl> I <decl> <varlist> . . 

We con recognize the end of a varlist by seeing if ^e next token is on 
identifier. An Id indicates the varlist continues. If it didn t we d 
see a keyword: either Begin. Procedure or Function. *) 
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PROCEDURE varIist(rout IneName:symboI); 

BEGIN 

dec I(routineName); 

IF peekTokenCIass() * Identifier THEN 
varlist(routineName); 

END; 

END varlist; 

(* <decl> <idlist> : <type> ; 

Declarations. All the work of putting information about the variables into 
the symbol table is done here. *) 

PROCEDURE dec I(routineName:symboI); 

VAR tl, tokenp:tokenList; 
t, idrtoken; 
tt:typeType; 

BEGIN 

tl idlistQ; 

tokenErrorCheck(CoIon, 'colon expected’); 
getToken(t); 

IF NOT IsTypeft.class) THEN 

compError('type name expected'); 
tt := tUnknown; 
ungetToken; 

ELSE 

tt :« tokenCIassToType(t.class); 

END; 

tokenErrorCheck(SemicoI on, 'semicolon expected'); 
tokenp := tI; 

(* Enter the variables into the symbol table. For globals, also generate 
the variabIes. *) 

WHILE NOT tlEmpty(tokenp) DO 
tIToken(tokenp, id); 

IF currentLexLeveI() * 0 THEN 

genGlobal(enterSymboI(id.string, Variable, tt)); 

ELSE 

enterLocal(id.string, tt, routineName); 

END; 

tokenp :* tINext(tokenp); 

END; 

freeTokenLIs t(11); 

END decl; 

(* <idlist> <id> | <id> , <idlist> *) 

PROCEDURE idlist():tokenList; 

VAR t: token; 

BEGIN 

getTokenErrorCheck(t, Identifier, 'identifier expected'); 

IF getTokenCIass() <> Comma THEN (* this is the end of the idlist *) 
ungetToken; 

IF t.class « Identifier THEN 

RETURN addToTokenList(t, emptyTokenList); 

ELSE 

RETURN emptyTokenList; 

END; 

(* we saw a comma, so there's more *) 

ELSIF t.class - Identifier THEN 

RETURN addToTokenList(t, idlist()); 

ELSE 

RETURN idlIst(); 

END; 

END idlist; 


(*** blocks and statements ***) 

(* <bIock> BEGIN <stmts> END *) 

PROCEDURE block(routineisymbol):node; 

VAR n:node; 

BEGIN 

tokenErrorCheck(Begin, 'BEGIN expected'); 
n stmts(routIne); 

tokenErrorCheck(End, '"END" expected'); 
RETURN n; 

END block; 


(continued) 
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(* <stmts> <empty> | <stmt> ; <stmts> 

We can recognize an empty <stmts> by seeing if the next token is ELSE, 
ELSIF or END. *) 

PROCEDURE stmts(routIne:symboI)inode; 

VAR n:node; 

tc:tokenCIass; 

BEGIN 

tc :■ peekTokenCIass(); 

IF (tc - Else) OR (tc - Elsif) OR (tc - End) THEN 
RETURN emptyNode; 

ELSE 

n :■ stmt(routine); 

tokenErrorCheck(SemicoI on, *a semicolon must end a statement'); 
RETURN makeStmtsNode(n, stmts(routine)); 

END; 

END stmts; 

(* <stmt> <while> I <if> | <return> | <assign> | <caI I> | 

<write> | <read> *) 

PROCEDURE stmt(routineisymbol);node; 

VAR t:token; 

BEGIN 

getToken(t); 

CASE t.cl ass OF 

If: RETURN ifStmt(routIne); 

I While: RETURN whiIeStmt(routine); 

| Return: RETURN returnStmt(routine); 

IF symbolEqual(routine, programName) THEN 

compError("can't return from main program"); 

ELSE 

RETURN makeReturnNode(routIne, expr()); 

END; 

Write: RETURN makeWriteNode(actuaIs()); 

Read: RETURN makeReadNode(actuaIs()); 

Identifier: RETURN assignOrCaI I Stmt(t); 

ELSE 

compError('I I IegaI statement type'); 

RETURN emptyNode; 

END; 

END stmt; 


(* <if> ::« IF <eIsif> END *) 

PROCEDURE ifStmt(routine:symboI):node; 

VAR n:node; 

BEGIN 

n :* elsif(routine); 
tokenErrorCheck(End, 'END expected'); 

RETURN n; 

END ifStmt; 

(* <eIsIf> ::= <expr> THEN <stmts> <else> *) 

PROCEDURE eIsif(routine:symboI):node; 

VAR nl, n2:node; 

BEGIN 

nl :* expr() ; 
boolCheck(nl); 

tokenErrorCheck(Then, 'THEN expected'); 
n2 :■ stmts(routine); 

RETURN makelfNode(n1, n2, eIse(routine)); 

END elsif; 

(* <else> ::= <empty> | ELSIF <elsif> | ELSE <stmts> 

We can tell an <else> is empty by seeing if the next token is END. *) 
PROCEDURE else(routine:symbol):node; 

BEGIN 

CASE getTokenClass() OF 
End: ungetToken; 

RETURN emptyNode; 

| Elsif: RETURN makeStmtsNode(eIsif(routine), emptyNode); 

Else: RETURN stmts(routine); 

ELSE 

compError('END, ELSIF or ELSE expected'); 
ungetToken; 

RETURN emptyNode; 

END; 
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END else; 

(* <while> WHILE <expr> DO <stmts> END *) 

PROCEDURE whlIeStmt(routine:symboI)inode; 

VAR ninode; 

BEGIN 

n ;* exprH; 

booICheck(n); 

tokenErrorCheck(Do, ’DO expected’); 
n i* makeWhiIeNode(n, stmts(routine)); 
tokenErrorCheck(End, ’END expected*); 

RETURN n; 

END whlIeStmt; 

(* <return> RETURN | RETURN <expr> *) 

PROCEDURE returnStmt(routineisymbol)mode; 

BEGIN 

IF symbolEquaI(routine, programName) THEN 

compError("can*t return from main program"); 

END; 

IF peekTokenClass() = Semicolon THEN 

RETURN makeReturnNode(routine, emptyNode); 

ELSE 

RETURN makeReturnNode(routine, expr()); 

END; 

END returnStmt; 

(* We can’t distinguish an assignment from a call based on the first token 
of the statement, since in both cases it’s an identifier. The next token, 
though, will distinguish: It's an assignment sign for an assignment. *) 

PROCEDURE assignOrCalIStmt(t;token)mode; 

BEGIN 

IF getTokenClassQ * Assignment THEN 
RETURN assignStmt(t); 

ELSE 

ungetToken; 

RETURN calIStmt(t); 

END; 

END assignOrCaI I Stmt; 

(* <assign> :i« <id> i« <expr> *) 

PROCEDURE assignStmt(varName:token)inode; 

VAR sisymboI; 

BEGIN 

s i* fIndSymboI(varName.strIng); 

IF NOT symbo1C IassEquaI(s, Variable) THEN 

compError(’only variables can be assigned to’); 

RETURN expr(); (* consume the expression anyway *) 

ELSE 

RETURN makeAssignmentNode(s, expr()); 

END; 

END assignStmt; 

(* <call> <id> <actuals> *) 

PROCEDURE cal I Stmt(rout IneNameitoken)mode; 

VAR procisymbol; 

BEGIN 

proc :■ findSymbol(routIneName.strIng); 

IF NOT symboICIassEquaI(proc, Proc) THEN 

compError('on Iy procedures can be used in a call statement'); 

RETURN actuaIs(); 

ELSE 

RETURN makeCalINode(proc, actuals()); 

END; 

END calIStmt; 

(* <actuals> <empty> | ( <exprllst> ) 

We can recognize an empty <actuals> by seeing if the next character is a 
left parenthesis. *) 

PROCEDURE actuaIs()mode; 

VAR ninode; 

BEGIN 

IF getTokenClass() ■ Lparen THEN 
n i- exprI 1st(); 

tokenErrorCheck(Rparen, ’right paren expected’); 

( continued) 
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RETURN n; 

ELSE 

ungetToken; 

RETURN emptyNode; 

END; 

END actuals; 

(* <exprIist> :<expr> | <expr> , <exprl1st> 

Exprlist always returns an nLlst node, even If there’s only one expr. *) 
PROCEDURE exprI 1st():node; 

VAR n:node; 

BEGIN 

n expr() ; 

IF getTokenClass() ■ Comma THEN 

RETURN makeExprLIstNode(n, exprllst()); 

ELSE 

ungetToken; 

RETURN makeExprLIstNode(n, emptyNode); 

END; 

END exprI 1st; 

BEGIN 

END Parser. 

+++++++ 

Start Routines.DEF 
+++++++ 

DEFINITION MODULE Routines; 

(* The part of the parser that deals with procedures and functions. 

Syntax: 

<routines> :<empty> | <proc> <routines> | <func> <routines> 

<proc> procedure <id> <formals> ; <vars> <block> ; 

<func> function <id> <formals> : <type> ; <vars> <block> ; 

<formaIs> <empty> | ( <formlist> ) 

<formlist> ::= <formdecl> | <formdecl> ; <formlist> 

<formdecl> ::*= <idI ist> : <typeld> 

*) 

EXPORT QUALIFIED routines; 

PROCEDURE routines; 

END Routines. 

+++++++ 

Start Routines.MOD 
+++++++ 

IMPLEMENTATION MODULE Routines; 


(* The part of the parser that handles procedures and functions. 

There are basically two things that have to be done: the routine 
declarations have to be processed to yield symbol table entries, and 
the code for the routine bodies has to be generated. The lists of 
formal parameters (arguments) and locals variables are placed in the 
appropriate slots in the symbol table entry for the routine. For 
functions, 

the return type of the function is put in the type slot of the symbol; for 
procedures, this slot is left undefined. An offset from the stack pointer 
is given to each local and formal. The initial offsets assume the 
following stack conventions: 


FP-> 


arg 1 
arg 2 

oidFP 

$P 

return 
loc 1 
loc 2 


stack grows down 
towards low memory 
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The list of formals must be backwards to match the argument conventions. 
The order of the locals doesn't matter, but it's also backwards. 

We generate code as if for a block, with two exceptions: at the 
beginning, 

we have to push enough words to move the stack pointer past the local 
storage area; while we are at it, we initialize the words to 0. At the 
end, we generate a return, in case the user didn't. For procedures, it 
Is okay to return by falling off the end. For functions, something has to 
be returned explicitly; it is an error to fall through. 

*) 

FROM Token IMPORT token, tokenClass, isType, typeType. tokenCIassToType, 
tokenList, tIEmpty, tINext, tIToken, freeTokenList; 

FROM LexAn IMPORT getToken, getTokenCIass, ungetToken, tokenErrorCheck, 
getTokenErrorCheck, compError, peekTokenCI ass; 

FROM Symbol IMPORT symbol, setSymboI Type, setSymbolOffset, 

symboIFormaIs, symboILocaIs, symbol List, si Next, si Symbol, si Empty, 
SymbolClass, numFormals, numLocals; 

FROM SymbolTable IMPORT enterSymbol, enterFormal, beginRoutine, endRoutine; 
FROM CodeGen IMPORT genBlock, genLocals; 

FROM CodeWrite IMPORT writelnt, writeFReturn, writeReturn, writeRoutineLabeI; 
FROM Parser IMPORT vars, idlist, block; 

FROM Node IMPORT node; 


CONST 

In 11la ILocalOffset * —1; (* offsets, in words, from the FP *) 

initiaIFormalOffset ■ 3; 


(* <routines> <empty> | <proc> <routines> | <func> <routines> *) 

PROCEDURE routines; 

BEGIN 

LOOP 

CASE getTokenCIass() OF 
Procedure: proc; 

| Function: func; 

ELSE ungetToken; EXIT; 

END; 

END; 

END routines; 

(* <proc> ::■ procedure <id> <formals> ; <vars> <routines> <block> ; *) 

PROCEDURE proc; 

VAR t:token; 
s:symboI; 

I:CARDINAL; 

BEGIN 

getTokenErrorCheck(t, Identifier, 'procedure name expected'); 
s :■ enterSymbol(t.string, Proc, tUnknown); 
beginRoutine(s); 
forma Is(s); 

tokenErrorCheck(SemicoIon, 'semicolon expected'); 

locaIs(s); 

routines; 

writeRoutineLabeI(s); 
genLocaIs(s); 
genBlock(block(s)); 
writeReturn(numFormaIs(s)); 

tokenErrorCheck(SemicoIon, 'semicolon expected'); 
endRoutlne(s); 

END proc; 

(* <func> ::■ function <id> <formaI8>:<type>; <vars> <routines> <block>; *) 

PROCEDURE func; 

VAR fname, ftype:token; 
s:symboI; 

1:CARDINAL; 

BEGIN 

getTokenErrorCheck(fname, Identifier, 'function name expected'); 
s :■ enterSymbol(fname.string, Func, tUnknown); 
beginRoutlne(s); 
forma Is(s); 

tokenErrorCheck(CoIon, 'colon expected'); 
getToken(ftype); 

(continued) 
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IF NOT l8Type(ftyp«.closs) THEN 

compError(’function type expected’); 

END; 

tokenErrorCheck(SemlcoIon, ’semicolon expected*); 
setSymboI Type(s, tokenCIassToType(ftype.cI ass)); 
loco Is(s); 
rout Ines; 

writeRoutIneLabeI (s) ; 
genLocal s(s) ; 

aenBlock(block(s)); _ , 

(* Here we should generate an error message in the code: value not 
returned from function. But since we have no string manipulation, 
we can’t. Instead we’ll return either 0 (for an Integer function) or 
false (which is also 0) for a boolean function. *) 
wr 1telnt(0); 

wr 1teFReturn(numFormaIs(s)); 

tokenEr rorCheck(SemicoI on, ’semicolon expected'); 
endRout1ne(s); 

END func; 

(* <formaIs> :<empty> | ( <formlist> ) *) 

PROCEDURE forma Is(routine:symbol); 

VAR formLlst :symbolUst; 

offset:INTEGER; 

BEGIN 

IF getTokenCIass() - Lparen THEN 
formlist(routine); 

tokenErrorCheck(Rparen, ’right paren expected’); 

ELSE 

ungetToken; 

END; 

(* Set the offsets of the formals *) 
formList :* symboI Forma Is(routine); 
offset :* initiaIFormalOffset; 

WHILE NOT sIEmpty(formList) DO 

setSymboIOffset(sISymboI(formList), offset); 

INC(offset); 

formList :■ sI Next(formL1st); 

END; 

END formals; 


(* <formlist> <formdecl> | <formdecl> ; <formlist> *) 
PROCEDURE formlist(rout Ine:symboI); 

BEGIN 

formdecI(rout 1ne); 

IF getTokenCI ass() * Semicolon THEN 
formlist(routine); 

ELSE 

ungetToken; 

END; 

END formlist; 

(* <formdecl> ::= <idIist> : <typeld> *) 

PROCEDURE formdecI(routine:symboI); 

VAR tl, tokenp:tokenList; 
t:token; 
tt:typeType; 

BEGIN 

tl :« idlist(); 

tokenErrorCheck(Co I on, "colon expected"); 
getToken(t); 

IF isType(t.cI ass) THEN 

tt :» tokenClassToType(t.class); 

ELSE 

compError("type name expected"); 
tt :* tUnknown; 
ungetToken; 

END; 

(* create and enter the symbols *) 
tokenp :* tI; 

WHILE NOT tlEmpty(tokenp) DO 
tIToken(tokenp, t); 

enterFormaI(t.string, tt, routine); 
tokenp := 11 Next(tokenp); 

END; 
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f reeTokenList(tI); 

END formdecI; 

PROCEDURE I oca Is(routine:symboI); 

(* Syntactically, locals look just like globals; but we have to put them 
into the locals list of the routine and give them offsets from the frame 
pointer. *) 

VAR locLlst:symbolList; 

offset:INTEGER; 

BEGIN 

vars(routine); 

locList :« symboILocaIs(routine); 
offset := initia ILocalOffset; 

(* set the offsets of the locals *) 

WHILE NOT slEmpty(locList) DO 

setSymboIOffset(sISymboI(IocList), offset); 

DEC(offset); 

locList :« sINext(locList); 

END; 

END locals; 


BEGIN 

END Routines. 

+++++++ 

Start SymboI.DEF 

+++++++ 

DEFINITION MODULE Symbol; 

(* The symbol data structure contains all the information about symbols (like 
variables and routine names). Symbol lists are used for lists of formals 
and locals. *) 

FROM Token IMPORT stringType, tokenClass, typeType; 

EXPORT QUALIFIED symbol, emptySymbol, SymbolClass, 

symbolClass, symboIString, symbolType, symboILexLeveI, symbolOffset, 
symboI Forma Is, symboILocaIs, symbolNext, symbolPrev, symboITokCI ass, 
setSymboI Forma Is, setSymboILocaIs, setSymboI Type, setSymboI Next, 
setSymboIPrev, setSymboI Offset, setSymboITokCI ass, 
symboICIassEquaI, symbolEmpty, symbolEqual, 
newSymbol, freeSymbol, numFormals, numLocals, 

symboIList, emptySymboILIst, slEmpty, sISymbol, sINext, addToSymboIList, 
freeSymbolList; 


TYPE 

symbol; 
symboIList; 

SymbolClass = (* the different kinds of symbols *) 

(Proc, Func, Variable, Keyword, Undeclared); 


VAR emptySymboI:symboI; 

emptySymboIList:symboIList; 

(*** Symbols ***) 

PROCEDURE symbo1C I ass(s:symboI):Symbo1C I ass; 
(★ Return the class of the symbol *) 


PROCEDURE symbolString(s:symbol; VAR str:stringType); 

(* Return the name of the symbol, as a string *) 

(* Symbols are declared to be of a certain type (except procedures) *) 
PROCEDURE symboIType(s:symboI):typeType; 

PROCEDURE setSymboIType(s:symboI; tt:typeType); 


PROCEDURE symboILexLeveI(s:symboI):CARDINAL; 

(* Return the lexical level at which the symbol was declared *) 

(* Each formal and local has an offset from the frame pointer. *) 

PROCEDURE symboI Of fset(s:symboI):INTEGER; 

PROCEDURE setSymbolOffset(s:symboI; o:INTEGER); 

(* These are for routines. They get and set the lists of formals and locals. 
*) 


(continued) 
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PROCEDURE symboI Forma Is(s:symboI):symboILis t; 

PROCEDURE symboI Loco Is(s:symboI):symboILis t; 

PROCEDURE setSymboI Forma Is(s:symboI; sI:symboIList); 

PROCEDURE setSymboILocaIs(s:symboI; sI:symboIList); 

(* Return the number of formals or locals In the routine. *) 

PROCEDURE numFormaIs(s:symboI):CARDINAL; 

PROCEDURE numLocaIs(s:symboI):CARDINAL; 

(* These next two are for implementing a doubly linked list. See 
SymbolTable.*) 

PROCEDURE symboI Next(s:symboI):symboI; 

PROCEDURE symbolPrev(s:symbol):symboI; 

PROCEDURE setSymboI Next(s1, s2:symbol); 

PROCEDURE setSymboIPrev(s1, s2:symbol); 

(* Keyword symbols have a corresponding token class. *) 

PROCEDURE symboITokCI ass(s:symboI):tokenCI ass; 

PROCEDURE setSymbolTokClass(s:symbol; tcrtokenClass); 

PROCEDURE symbo1C IassEquaI(s:symboI; sc:Symbo1C I ass):BOOLEAN; 

(* Returns TRUE if the class of s equals sc. *) 

PROCEDURE symboI Equal(si, s2:symboI):BOOLEAN; 

(* Returns TRUE if the two symbols are the same. *) 

PROCEDURE symboI Empty(s:symboI):BOOLEAN; 

(* Returns TRUE if the symbol is the emptySymbol. *) 

PROCEDURE newSymbol(VAR str:stringType; sc:Symbo1C I ass; scop:CARDINAL; 

tt;typeType):symboI; 

(* Creates a new symbol. *) 

PROCEDURE freeSymbol(s:symboI); 

(* Frees the storage associated with s. *) 

(*** Symbol Lists ***) 

PROCEDURE sI Empty(sI;symboIList):BOOLEAN; 

(* Returns TRUE if si is the empty symbol list. *) 

PROCEDURE sI Next(si;symboILis t):symboILis t; 

(* Gets the rest of the symbol list. *) 

PROCEDURE siSymboI(si:symboIList):symboI; 

(* Gets the first symbol in the list *) 

PROCEDURE addToSymboIList(s:symboI; si;symbolList):symbolList; 

(* Adds s to si at the front. Return the new symbol list. *) 

PROCEDURE freeSymbolList(si:symboIList); 

(* Frees the storage associate with si (but NOT the storage of the symbols 
in sli *) 

END Symbol. 

+++++++ 

Start Symbol.MOD 
+++++++ 

IMPLEMENTATION MODULE Symbol; 

(* Symbol and symbol list data structures. *) 

FROM Token IMPORT stringType, tokenClass, typeType, tokenCIassToType; 

FROM Storage IMPORT ALLOCATE. DEALLOCATE; 

FROM MyTerminal IMPORT fatal; 

TYPE 

symbol = POINTER TO symbolRec; 
symbolList *» POINTER TO sIRec; 

symbolRec * RECORD 

string: stringType; 
lexLevel: CARDINAL; 
type: typeType; 
next, prev: symboI; 
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offset:INTEGER; 

CASE class: SymbolClass OF 

Proc, Func: formals, locals: symbolList; 
Keyword: tokClass: tokenClass; 

END; 

END; 

sIRec ■ RECORD 

sym: symbol; 
next: symbolList; 

END; 

(*** getting fields ***) 

PROCEDURE symbolClass(s:symbol):Symbo1C I ass; 

BEGIN 

RETURN s^.class; 

END symbolClass; 

PROCEDURE symbolStrlng(s:symbol; VAR str:strIngType); 

BEGIN 

str :» s^.string; 

END symbolstring; 

PROCEDURE symboIType(s:symboI):typeType; 

BEGIN 

RETURN s^.type; 

END symboI Type; 

PROCEDURE symboILexLeveI(s:symboI):CARDINAL; 

BEGIN 

RETURN s^.lexLevel; 

END symboILexLeveI; 

PROCEDURE symboI Of fset(s:symboI):INTEGER; 

BEGIN 

RETURN s^.offset; 

END symbolOffset; 

PROCEDURE symbolFormals(s:8ymbol):symboIList; 

BEGIN 

IF (s A .cI ass - Proc) OR (s*.class - Func) THEN 
RETURN s*.formals; 

ELSE 

fata I(*symboI Forma Is: not a proc or func*); 

END; 

END symboI Forma Is; 

PROCEDURE symboILocaIs(s:symboI):symboILIst; 

BEGIN 

IF (s^.class - Proc) OR (s*.class « Func) THEN 
RETURN s*.locals; 

ELSE 

fatal(‘symbolLocaIs: not a proc or func*); 

END; 

END symboILocaIs; 

PROCEDURE symboI Next(s:symboI):symboI; 

BEGIN 

IF s * emptySymbol THEN 

fata I(*symboINext: empty symbol given*); 

ELSE 

RETURN s*.next; 

END; 

END symboI Next; 

PROCEDURE symbolPrev(8:symboI):symboI; 

BEGIN 

RETURN s^.prev; 

END symbolPrev; 

PROCEDURE symboITokCI ass(s:symboI):tokenCI ass; 

BEGIN 

IF s*.class ■ Keyword THEN 
RETURN s*.tokClass; 


{continued) 


i 


BYTE LISTINGS SUPPLEMENT 51 



January 


ELSE 

fata I('symboITokCIass: not a keyword*); 

END; 

END symboITokCIass; 

(*** setting fields ***) 

PROCEDURE setSymbolFormals(s:symbol; sI:symbolList); 
BEG IN 

IF (s*.class - Proc) OR (s*.class - Func) THEN 
s*.formats :■ si; 

ELSE , , x 

fatal ('set Symbol Formale: not a proc or func ); 

END; 

END setSymboI Forma Is; 

PROCEDURE setSymbolLocals(s;symbol; si:symbolList); 

begin v _ x TLjrikl 

IF (s*.class « Proc) OR (s*.class ■ Func) THEN 
s*.locals :* sI; 

ELSE . . \ 
fatal('setSymboI Locals: not a proc or func ); 

END; 

END setSymboI Locals; 

PROCEDURE setSymboIType(8:symboI; tt:typeType); 

BEGIN 

s*.type :« tt; 

END setSymbolType; 

PROCEDURE setSymboI Next(s1, s2:symbol); 

BEGIN 

si*.next :* s2; 

END setSymboI Next; 

PROCEDURE setSymboIPrev(s1, s2:symbol); 

BEGIN 

s1*.prev ;* s2; 

END setSymbolPrev; 

PROCEDURE setSymboI Offset(s:symboI; o;INTEGER); 

BEGIN 

s*.offset :« o; 

END setSymbolOffset; 

PROCEDURE setSymbo ITokCIass(s:symboI; tc:tokenCIass); 
BEGIN 

IF s^.class * Keyword THEN 
s*.tokClass :■ tc; 

else 

fata I('setSymboITokCIass: not a keyword'); 

END; 

END setSymboITokCIass; 

(*** other symbol procedures ***) 


PROCEDURE symbo1C IassEquaI(s:symboI; sc:Symbo1C I ass);BOOLEAN; 

begin % x 

RETURN (s*.class - Undeclared) OR (s .class - sc); 

END symbo1C IassEquaI; 

PROCEDURE symboI Equal(si, s2:symboI):BOOLEAN; 

BEGIN 

RETURN si « s2; 

END symboI Equal; 

PROCEDURE symbolEmpty(s:symbol)‘.BOOLEAN; 

BEGIN 

RETURN s « emptySymbol; 

END symboI Empty; 

PROCEDURE newSymbol(VAR str:stringType; sc:Symbo1C I ass; I I;CARDINAL; 
tt:typeType):symboI; 

VAR s-.symbol; 

BEGIN 
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NEW(s); (* should be: NEW(s, sc); *) 

WITH s* DO 

string :■ str; 
lexLevel :— II; 
type :■ tt; 
next :■ emptySymbol; 
prev :* emptySymbol; 
class :« sc; 

CASE class OF 
Proc, Func: 

forma Is :■ emptySymboILIst; 
locals :■ emptySymboIL1st; 

Varlab Ie: offset :■ 0; 

ELSE (* do nothing *) 

END; 

END; 

RETURN s; 

END newSymbol; 

PROCEDURE freeSymboI(s:symboI); 

BEGIN 

DISPOSE (s); (* should be: DISPOSER, s^.class); *) 

END freeSymboI; 

PROCEDURE numFormaIs(s:symbol):CARDINAL; 

VAR formLIst:symboILIst; 

count:CARDINAL; 

BEGIN 

count :« 0; 

formList :■ symboI Forma Is(s); 

WHILE NOT sIEmpty(formList) DO 
INC(count); 

formList sI Next(formList); 

END; 

RETURN count; 

END numFormals; 

PROCEDURE numLocals(s:symbol):CARDINAL; 

VAR locLIstisymbolList; 

count CARDINAL; 

BEGIN 

count :* 0; 

locList :* symboI Loco Is(s); 

WHILE NOT sIEmpty(IocL1st) DO 
INC(count); 

locList slNext(locList); 

END; 

RETURN count; 

END numLocals; 

(*** symbolList ***) 

PROCEDURE si Empty(si:symboILIst):BOOLEAN; 

BEGIN 

RETURN si * emptySymboIList; 

END slEmpty; 

PROCEDURE sINext(sI:symboILIst):symboILIst; 

BEGIN 

RETURN sr.next; 

END si Next; 

PROCEDURE sISymboI(sI:symboILIst):symboI; 

BEGIN 

RETURN sl^.sym; 

END 8 ISymboI; 

PROCEDURE addToSymbolLlst(s:symbol; si:symboILIst):symboILIst; 
VAR news I: symbolList; 

BEGIN 

NEW(newsI); 
newsl^.sym :■ s; 
newsP.next :■ si; 

RETURN news I; 

END addToSymbolLlst; 


January 
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PROCEDURE freeSymbolLIst(sl:symboI List'; 

BEGIN , % 

IF NOT slEmpty(sl) THEN 

freeSymboIList(sI Next(sI)); 
DISPOSE(sl); 

END; 

END freeSymbolList; 


BEGIN 

emptySymbol :* NIL; 
emptySymbolUst :■* NIL; 
END Symbol. 


+++++++ 

Start SymboI Tab Ie.DEF 
+++♦+++ 

DEFINITION MODULE SymbolTable; 

(* The symbol table associates symbol records with names of symbols. *) 

FROM Symbol IMPORT symbol, SymbolClass; 

FROM Token IMPORT stringType. tokenClass, typeType; 

EXPORT QUALIFIED enterSymbol, enterLoccI, enterFormal, findSymbol, 

^ enterKeyword, beginRou ine, endRoutlne, currentLexLeve I , 

PROCEDURE currentLexLevel():CARDINAL; 

(* Returns the current lexical level *) 


If the 


(* Enter global, local, formal, keyword symbols Into table. 

enterSymbol Is the general routine and returns the entered symbol. 
symbol is already present, an error is signalled. EnterLocal and 
enterFormal are used for local variables and formal parameters only; they 
take care of inserting the symbol into the list of locals or formals. 
respectively, which Is associated with the routine. *) 

PROCEDURE enterSymbol(VAR s:strIngType; symc:SymbolClass; tt: 

PROCEDURE'enterLocaI(VAR s:stringType; tt-.typeType; routine:symboI); 
PROCEDURE enterFormal(VAR s:stringType; tt:typeType; routine:symbo ), 
PROCEDURE enterKeyword(s:stringType; tc:tokenCI ass); 


Return the empty symbol 


PROCEDURE findSymbol(VAR s:stringType):symboI; 

(* Look up the symbol in the table and return it. 
if not found. *) 

PROCEDURE findKeyword(VAR s:str IngType; VAR tc:tokenCIass):BOOLEAN; 

(* Look up the keyword in the table and put its corresponding token class 
in tc. Return FALSE if the symbol wasn't found. *) 

PROCEDURE beginRoutine(rname:symboI); 

(* To be called just after the routine name has been entered. Increments 
lexical level. Also assigns a unique number to the routine if it isn t 

gIobaI. *) 


This includes 


PROCEDURE endRoutine(rname:symbol); 

(* Clean up the symbol table after a routine has been compiled, 
deleting the locals and formals from the table. *) 

END SymbolTable. 

+++++++ 

Start SymboI Tab Ie.MOD 

+++++++ 

IMPLEMENTATION MODULE SymbolTable; 

(* The symbol table for the SIMPL compiler. It is a hash table; each entry 
is a symboI.possibly linked through the NEXT field to other symbols. The 
list of symbols is doubly linked, to make it easy to delete from the 

^W^sti11 have to rehash to delete from the beginning, though. This could 
be gotten around by hanging a dummy record off of every hashtable entry. 

*) 

FROM Symbol IMPORT symbol, SymbolClass. emptySymbol, newSymbol, 

symbo I Forma Is. symboI Loco Is. symboI Empty, symbo1 Strmg. symbolLexLevel. 
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symboI Next, symboIPrev, setSymboI Next, setSymboIPrev, setSymboILocaIs, 
setSymbolFormals, freeSymbol, symbolClass, symbolEqual, symboITokCI ass, 
setSymboITokCI ass, emptySymboIList, numFormals, setSymbolOffset, 
symbolLlst, slEmpty, sINext, sISymbol, addToSymboIList, freeSymboIList; 
FROM Token IMPORT stringType, tokenClass, typeType; 

FROM LexAn IMPORT compError; 

FROM MyTerminal IMPORT fatal; 

FROM StrlngStuff IMPORT stringEqual; 

CONST symTabSize = 20; 

(* This is NOT an upper limit on the number of symbols, 

since we have linked lists coming off of the hashtable entries. Still, 
the compiler may run faster (because the lists It searches are shorter) 
if this number is increased. *) 

VAR symboI Table: ARRAY[0..symTabSize-1] OF symbol; 
lexicalLeveI: CARDINAL; 

PROCEDURE currentLexLeveI():CARDINAL; 

BEGIN 

RETURN I exicalLeveI; 

END currentLexLeveI; 

PROCEDURE enterLocaI(VAR s:stringType; tt:typeType; rout Ine:symboI); 

VAR sym:symbol; 

BEGIN 

sym :* enterSymboI(s, Variable, tt); 

setSymboILocaIs(routine, addToSymboI List(sym, symboILocaIs(routine))); 
END enterLocaI; 

PROCEDURE enterFormaI(VAR s:stringType; tt:typeType; routine:symboI); 

VAR sym:symboI; 

BEGIN 

sym enterSymboI(s, Variable, tt); 

setSymboIFormals(routine, addToSymboIList(sym, symboIFormals(routlne))); 
END enterFormaI; 

PROCEDURE enterKeyword(s:stringType; tc:tokenClass); 

VAR sym:symbol; 

BEGIN 

sym :« enterSymboI(s, Keyword, tUnknown); 
setSymbolTokClass(sym, tc); 

END enterKeyword; 

(*** symbol insertion ***) 

PROCEDURE enterSymboI(VAR s:stringType; symc:Symbo1C I ass; tt: 
typeType):symboI; 

(* This does the real work of entering a symbol. It signals an error 
if a symbol Is redefined. *) 

VAR sym:symbol; 

h:CARDINAL; 

BEGIN 

sym := lookup(s, FALSE, h); 

IF symboIEmpty(sym) THEN 

RETURN insert(newSymbol(s, symc, I exicaILeveI, tt), h); 

ELSE 

compError(*redefined symbol*); 

RETURN sym; 

END; 

END enterSymboI; 

(*** symbol lookup ***) 

PROCEDURE findSymboI(VAR s:strIngType):symboI; 

VAR sym; symbol; 

h: CARDINAL; 

BEGIN 

sym :« lookup(s, TRUE, h); 

IF symbolEmpty(sym) THEN 

compError(*undefined symbol*); 

RETURN lnsert(newSymbol(s. Undeclared, 0, tUnknown), h); 

ELSE 

RETURN sym; 

END; 

END fIndSymboI; 
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PROCEDURE findKeyword(VAR s:stringType; VAR tc:tokenCI ass):BOOLEAN; 

(* This Is used by the lexical analyzer to return the keyword’s token class. 
Returns true If the keyword is found; tc will then contain the token 
class of the keyword. *) 

VAR sym:symbol; 

h:CARDINAL; 

BEGIN 

sym ;« lookup(s, TRUE, h); 

IF symboIEmpty(sym) OR (symbolClass(sym) <> Keyword) THEN 
RETURN FALSE; 

ELSE 

tc :« symbolTokClass(sym); 

RETURN TRUE; 

END; 

END findKeyword; 

PROCEDURE Iookup(VAR s:stringType; anything:BOOLEAN; VAR h:CARDINAL);symboI; 

(* Looks up the string in the symbol table. Returns the empty symbol if 
the string isn’t found; if it is. returns the symbol and, in h, the hash 
value, anything TRUE means: "match anything". 

This is what findSymbol uses. We match lexical level on insertion, to 
check for redefined symbols. 

*) 

VAR sym; symbol; 

syms; stringType; 

BEGIN 

h :■ hash(s); 

sym := symboITabIe[h]; 

WHILE NOT symboIEmpty(sym) DO 
symboIString(sym, syms); 

IF stringEquaI(syms, s) AND 

(anything OR (I exicaILeveI = symboILexLeveI(sym))) THEN 
RETURN sym; 

END; 

sym :*= symbo I Next (sym); 

END; 

RETURN emptySymbol; 

END lookup; 

PROCEDURE Insert(s:symboI; h:CARDINAL):symboI; 

(* Link the symbol into the h'th symbol table entry. The symbol is put at 
the front of the list. *) 

BEGIN 

setSymboI Next(s, symboI Tab Ie[h]); 
setSymboIPrev(s, emptySymbol); 
symboI Tab Ie[h] := s; 

RETURN s; 

END insert; 

MODULE begRout; (* This needs to be a module because a variable needs 
to be remembered across invocations. *) 

IMPORT symboILexLeveI, setSymboI Offset, symbol, I exicaILeveI; 

EXPORT beginRoutine; 

VAR num;INTEGER; 

PROCEDURE beginRoutine(rname:symboI); 

BEGIN 

IF symboILexLeveI(rname) <> 0 THEN f* assign a unique number to *) 
setSymboI Offset(rname, num); non-global procedures *) 

INC(num); 

END; 

INC(lexicalLeveI); 

END beginRoutine; 

BEGIN 

num :« 0; 

END begRout; 

PROCEDURE endRoutine(rname:symboI); 

(* This is the stuff we do at the end of compiling a procedure or function. 

The free’s are just to reclaim storage. The remove’s remove the symbols 
from the symbol table, which is important if some local symbol is 
shadowing a global symbol. We remove both locals and formals, but we don’t 
free the formals because we need them for type checking. 

We also remove the routines declared at this lexical level, and free 

the i r 
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formals. We find these routines by searching the entire symbol table—it 
would probably be better to keep a list of them. 

*) 

BEGIN 

removeSymboIList(symboI Loco Is(rname)); 
freeSymboIs(symboILocaIs(rname)) ; 
freeSymboI List(symboILocaIs(rname)) ; 
setSymboILocaIs(rname, emptySymboIList); 
removeSymboIList(symboI Forma Is(rname)); 
removeRoutinesAtThisLeveI; 

DEC(lexicalLeveI); 

END endRoutine; 


PROCEDURE removeSymboIList(symboIp:symbo(List); 

BEGIN 

WHILE NOT slEmpty(symbolp) DO 

removeSymboI(sISymboI(symboIp)); 
symbolp :* sI Next(symboIp); 

END; 

END removeSymbolList; 

PROCEDURE removeRoutinesAtThisLeveI; 

(* Remove all routines defined at this lexical level. Free their formals. 

All the symbols at this lexical level will be at the beginning of their 
respective buckets in the symbol table, and they all will be routines. *) 

VAR i:CARDINAL; 

s , next:symboI; 

BEGIN 

FOR i :* 0 TO symTabSize-1 DO 
s :® symboI Tab Ie[i]; 

WHILE (NOT symbolEmpty(s)) AND (symboILexLeveI(s) = I exicaILeveI) DO 
freeSymboIs(symboI Forma Is(s)); 
freeSymboIList(symboI Forma Is(s)); 

(* remove this symbol from the table *) 
next := symboINext(s); 
symboI Tab Ie[i] :* next; 

IF NOT symboI Empty(next) THEN 

setSymboIPrev(next, emptySymboI); 

END; 

freeSymboI(s); 
s := next; 

END; 

END; 

END removeRoutinesAtThisLeveI; 

PROCEDURE removeSymboI(s:symboI); 

(* Splice the symbol out of the symbol table. If the symbol is at the 
beginning of the list, we have to rehash to find the right entry. 

Otherwise, just remove It from the list. *) 

VAR bucketiCARDINAL; 

syms: stringType; 

BEGIN 

IF symboIEmpty(symboIPrev(s)) THEN 
symboIStrlng(s, syms); 
bucket :* hash(syms); 

IF NOT symboIEquaI(symboI Tab Ie[bucket], s) THEN 
fata I('removeSymboI: error*); 

ELSE 

symbolTable[bucketl :« symboINext(s); 

IF NOT symbolEmpty(symbolNext(s)) THEN 

setSymbolPrev(symbolNext(s), emptySymbol); 

END; 

END; 

ELSE 

setSymbolNext(symbolPrev(s), symboI Next(s)); 

IF NOT symboIEmpty(symboINext(s)) THEN 

setSymboIPrev(symboI Next(s), symboIPrev(s)); 

END; 

END; 

END removeSymboI; 

PROCEDURE freeSymboIs(symboIp:symboIList); 

VAR nextSymbolisymbolLIst; 

BEGIN 

WHILE NOT sIEmpty(symbolp) DO 

(continued) 
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nextSymbol sI Next(symboIp); 
freeSymbol(sISymboI(symboIp)); 
symboIp :■ nextSymbol; 

END; 

END freeSymbols; 


(*** low-level stuff ***) 

PROCEDURE hosh(VAR s:str!ngType):CARDINAL; 

(* A simple hosh function: just add up the ASCII values of the characters. *) 
VAR I, sum:CARDINAL; 

BEGIN 

i :« 0; 
sum :» 0; 

WHILE s[I] <> 0C DO 

sum :« sum + ORD(s[i]); 

INC(i); 

END; 

RETURN sum MOD symTabSize; 

END hash; 


PROCEDURE InitSymbolTable; 

VAR 1;CARDINAL; 

BEGIN 

FOR 1 0 TO symTabSize-1 DO 

symboITabIe[I] :* emptySymbol; 

END; 

END InitSymbolTable; 

BEGIN 

initSymboITabIe; 
lexicalLevel :** 0; 

END SymboITabIe. 

+++++++ 

Start Token.DEF 
+++++++ 

DEFINITION MODULE Token; 

(* Tokens are what the lexical analyzer returns to the parser. Keywords are 
distinct tokens, as are the special characters like parens, colon, etc. 
This module also exports typeType, which is a list of the possible types 
of variables in SIMPL. For now, SIMPL only has integers, booleans and 
characters. TokenLists are lists of tokens; they are used in the "varlist 
procedure of the parser. 

*) 

EXPORT QUALIFIED token, tokenClass, stringType, stringlen, isType, isRelation 
typeType, tokenCIassToType, 

tokenList, emptyTokenList, tIToken, tINext, addToTokenList, 
tIEmpty, freeTokenList; 

CONST stringlen « 80; 

TYPE 

tokenClass « (And, Assignment, Begin, Boolean, Char, Character, Colon, 
Comma, Divide, Do, Else, Elsif, End, EndOflnput. Equal, False, 
Function, Greater, GreaterEquaI, Identifier, If, Int, Integer, Less, 
LessEqual, Lparen, Minus, Not, NotEqual, Or, Period, Plus, Procedure, 
Program, Read, Return, Rparen, Semicolon, String, Then, Times, True, 
UMlnus, Var, While, Write); 


stringType = ARRAY[0..stringIen] OF CHAR; 

token * RECORD 

CASE class:tokenClass OF 

Identifier, String: string: stringType; 
Int: integer: INTEGER; 

Character: ch: CHAR; 

END; 

END; 
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tokenList; 

typeType ■ (tlnteger, tBoolean, tChar, tUnknown); 

VAR emptyTokenList: tokenList; 

PROCEDURE tokenCIassToType(tc:tokenCIass):typeType; 

(* Converts the token class Integer to the type tlnteger, and so on. *) 

PROCEDURE isType(tc:tokenCI ass):BOOLEAN; 

(* Returns TRUE If tc ■ Integer, Char, or Boolean *) 

PROCEDURE isReI ation(tc:tokenCI ass):BOOLEAN; 

(* Returns TRUE If tc is a relational operator (Equal, Greater, etc.) *) 

PROCEDURE tIToken(tl:tokenList; VAR t:token); 

(* Gets the first token in the token list. *) 

PROCEDURE 11 Next(tI:tokenList):tokenList; 

(* Gets the rest of the token list. *) 

PROCEDURE addToTokenList(VAR t:token; tI:tokenList);tokenList; 

(* Add a token to the beginning of the token list. *) 

PROCEDURE freeTokenList(tI:tokenList); 

(* Free the storage used by the token list. *) 

PROCEDURE 11 Empty(tI:tokenList):BOOLEAN; 

(* Return TRUE if the token list is empty. *) 

END Token. 

+♦+++++ 

Start Token.MOD 
+++++++ 

IMPLEMENTATION MODULE Token; 

(* Tokens and token lists for the SIMPL compiler. *) 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM Terminal IMPORT WriteString; 

TYPE tokenList - POINTER TO tokenListRec; (* token lists are linked lists *) 

tokenLlstRec * RECORD 

tok; token; 
next; tokenList; 

END; 

PROCEDURE tokenCIa$sToType(tc:tokenCI ass):typeType; 

BEGIN 

CASE tc OF 

Integer: RETURN tlnteger; 

I Boolean: RETURN tBoolean; 

Char: RETURN tChar; 

ELSE 

WriteString('tokenCIassToType: unknown type*); 

RETURN tUnknown; 

END; 

END tokenCIassToType; 

PROCEDURE isType(tc:tokenCI ass):BOOLEAN; 

BEGIN 

RETURN (tc - Integer) OR (tc - Boolean) OR (tc « Char); 

END isType; 

PROCEDURE IsReI ation(tc:tokenCIass):BOOLEAN; 

BEGIN 

RETURN (tc - Equal) OR (tc * NotEqual) OR (tc - Greater) OR 
(tc - GreaterEquaI) OR (tc ■ Less) OR (tc ■ LessEqual); 

END IsRelation; 

PROCEDURE 11 Token(tI:tokenList; VAR t:token); 

BEGIN 

IF tlEmpty(tl) THEN 

WriteString("tIToken: empty tokenList"); 

ELSE 

[continued) 
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t tr.tok; 

END; 

END 11 Token; 

PROCEDURE 11 Next(tIitokenList)itokenList; 

BEGIN 

RETURN tr.next; 

END 11 Next; 

PROCEDURE oddToTokenLIst(VAR t:token; tI:tokenLiet):tokenLIst; 

(* Create a token list record for the new token and splice it on to the 
front of the token list. Return ( a pointer to) the new record. *) 
VAR newt I: tokenL1st; 

BEGIN 

NEW(newtl); 
newtl^.tok :■ t; 
newt I*.next :* 11; 

RETURN newt I; 

END addToTokenList; 

PROCEDURE freeTokenLlst(tI:tokenL1st); 

BEGIN 

IF NOT tlEmpty(tl) THEN 

freeTokenList(tI Next(t I )); 

DISPOSER I ); 

END; 

END freeTokenLIst; 

PROCEDURE tlEmpty(tI:tokenL1st):BOOLEAN; 

BEGIN 

RETURN tl - emptyTokenLIst; 

END tIEmpty; 


BEGIN 

emptyTokenLIst :■ NIL; 

END Token. 

+++++++ 

Start TypeChecker.DEF 
+++++++ 

DEFINITION MODULE TypeChecker; 

(* Handles the actual type-checking of SIMPL expressions and statements. *) 

FROM Token IMPORT tokenClass, typeType; 

FROM Node IMPORT node; 

FROM Symbol IMPORT symbol; 

EXPORT QUALIFIED typeCompatIbIe, opApproprI ate, callCheck, readCheck, 

writeCheck, boolCheck, assignCheck, binopCheck, unopCheck, 
returnCheck; 

PROCEDURE typeCompatlb Ie(t1, t2:typeType):BOOLEAN; 

(* Returns TRUE if tl and t2 are compatible types. In order to avoid 
cascades of error messages, If one or both of the types is tUnknown, 
it still returns TRUE. *) 

PROCEDURE opAppropriate(op:tokenClass; arg:node):BOOLEAN; 

(* Returns TRUE if the type of the argument can be handled by the operator *) 
PROCEDURE calICheck(routineisymbol; args:node); 

(* Checks the procedure or function call for right number and types of args. 
*) 

PROCEDURE readCheck(actuaIs:node); 

(* Checks the call to the READ built-in procedure. *) 

PROCEDURE writeCheck(actuaIs:node); 

(* Checks the call to the WRITE built-in procedure. *) 

PROCEDURE boo I Check(ninode); 

PROCEDURE assignCheck(varisymbol; exprinode); 

PROCEDURE returnCheck(routlneisymboI; exprinode):BOOLEAN; 


.h*». 
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PROCEDURE binopCheck(op:tokenCloss; leftorg, rightarg:node):BOOLEAN; 

PROCEDURE unopCheck(op;tokenCI ass; arg;node):BOOLEAN; 

END TypeChecker. 

♦+++♦++ 

Start TypeChecker.MOD 
♦+++♦++ 

IMPLEMENTATION MODULE TypeChecker; 

(* Handles type-checking of SIMPL expressions. *) 

FROM Node IMPORT node, nodeType, nodeFirst, nodeRest, nodeEmpty, nodeClass, 
NodeCI ass, nodeSymboI; 

FROM Token IMPORT tokenClass, strlngType, typeType; 

FROM Symbol IMPORT symbol, symbol Type, symboI Forma Is, symbol List, 
symbolstring, 

sINext, sISymbol, slEmpty, symbo1C IassEquaI, SymbolClass, symbolClass, 
numFormaIs; 

FROM MyTerminaI IMPORT fatal; 

FROM LexAn IMPORT compError; 

PROCEDURE opAppropriate(op:tokenCI ass; arg:node):BOOLEAN; 

BEGIN 

CASE op OF 

Plus, Minus, UMinus, Times, Divide: 

RETURN typeCompatibIe(nodeType(arg), tlnteger); 

| Greater, GreaterEquaI, Less, LessEaual: 

RETURN typeCompatibIe(nodeType(arg), tlnteger) OR 
typeCompatibIe(nodeType(arg), tChar); 

| And, Or, Not: 

RETURN typeCompatlb Ie(nodeType(arg), tBoolean); 

| Equal, NotEqual: 

RETURN TRUE; 

ELSE 

fata I("opApproprI ate: unknown op type"); 

END; 

END opAppropriate; 

PROCEDURE typeCompatibIe(11, 12:typeType):BOOLEAN; 

BEGIN 

IF (tl - tUnknown) OR (t2 - tUnknown) THEN 
RETURN TRUE; 

ELSE 

RETURN tl - t2; 

END; 

END typeCompatibIe; 

PROCEDURE caIICheck(rout1ne:symboI; args:node); 

(* Tricky because formats are stored backwards In symbol, but forwards 

in the call to the routine. We do nothing if the symbol Is not a procedure 
or function; that check is handled in the parser. *) 

VAR nFormals, nActuaIs:CARDINAL; 

dummy:node; 

BEGIN 

IF (symboICIass(routIne) « Proc) OR (symboICIass(routIne) * Func) THEN 
nFormals :- numFormaIs(rout1ne); 
nActuals :- numActuaIs(args); 

IF nActuals < nFormals THEN 

compError(* too few arguments to routine*); 

ELSIF nActuals > nFormals THEN 

compError(*too many arguments to routine*); 

END; 

dummy :■ argsMatch(symboI Forma Is(routine), args); 

END; 

END calICheck; 

PROCEDURE orgsMatch(fI Ist:symboILIst; a I 1st:node)inode; 

(* This procedure matches two lists, one of which is backwards. It does 
It by recursing down one list all the way, then iterating down the other 
list while unrecursing. *) 

BEGIN 

IF sIEmpty(flist) THEN 
RETURN a I 1st; 


(continued) 
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allst argsMatch(sINext(fIist) , a I 1st); 

IF nodeEmpty(alist) THEN 
RETURN a Iist; 

ELSE 

argCheck(sISymboI(fIist). nodeFirst(alist)); 

RETURN nodeRest(a Iist); 

END; 

END; 

END argsMatch; 

PROCEDURE argCheck(formalisymbol; actuaI:node); 

VAR s:stringType; 

BEGIN 

IF NOT typeCompatibIe(symboIType(formaI), nodeType(actuaI)) THEN 
compError('type of formal does not match type of actual'); 

END; 

END argCheck; 

PROCEDURE numActuaIs(actuaIs:node):CARDINAL; 

VAR count:CARDINAL; 

BEGIN 

count 0; 

WHILE NOT nodeEmpty(actuals) DO 
INC(count); 

actuals :* nodeRest(actuaIs); 

END; 

RETURN count; 

END numActuals; 

PROCEDURE readCheck(actuaIs:node); 

VAR argmode; 

BEGIN 

IF nodeEmpty(actuals) THEN 

compError('READ requires an argument'); 

ELSE 

REPEAT 

arg nodeFIrst(actuaIs); 

IF nodeCIass(arg) <> nSymbol THEN 

compError('READ must have a variable as an argument'); 
ELSIF NOT symbo1C IassEquaI(nodeSymboI(arg), Variable) THEN 
compError('READ must have a variable as an araument'); 
ELSIF NOT (typeCompatibIefnodeTypefarg}, tlnteaer) OR 
typeCompatibIe(nodeType(arg), tCharj) THEN 
compError('READ can only read integers or characters'); 

END; 

actuals : = nodeRest(actuaIs); 

UNTIL nodeEmpty(actuaIs); 

END; 

END readCheck; 

PROCEDURE writeCheck(actuaIsmode); 

VAR argmode; 

BEGIN 

IF nodeEmpty(actuaIs) THEN 

compError('WRITE requires an argument'); 

ELSE 

REPEAT 

arg :« nodeFirst(actuaIs); 

IF NOT (typeCompatibIe(nodeType(arg), tlnteger) OR 

typeCompatibIe(nodeType(arg), tChar)) THEN 
compError('WRITE can only write integers or characters’); 

END; 

actuals :» nodeRest(actuaIs); 

UNTIL nodeEmpty(actuaIs); 

END; 

END wr1teCheck; 

PROCEDURE binopCheck(op:tokenCI ass; leftarg, rightarg:node):BOOLEAN; 

BEGIN 

IF NOT opAppropriate(op, leftarg) THEN 

compError('inappropriate arg type: left arg*); 

RETURN FALSE; 

END; 

IF NOT opAppropriate(op, rightarg) THEN 

compError(*inappropriate arg type: right arg'); 
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RETURN FALSE; 

END; 

IF NOT typeCompatible(nodeType(leftarg), nodeType(rightarg)) THEN 
compError(’argument types not compatible*); 

RETURN FALSE; 

ELSE 

RETURN TRUE; 

END; 

END binopCheck; 

PROCEDURE unopCheck(op:tokenClass; arg:node)-.BOOLEAN; 

BEGIN 

IF NOT opAppropriate(op, arg) THEN 

compError(*inappropriate arg type’); 

RETURN FALSE; 

ELSE 

RETURN TRUE; 

END; 

END unopCheck; 

PROCEDURE assignCheck(var:symboI; exprinode); 

BEGIN 

IF NOT typeCompatible(symbolType(var), nodeType(expr)) THEN 
compError('types not assignment compatible’); 

END; 

END assignCheck; 

PROCEDURE boolCheck(n-.node); 

BEGIN 

IF NOT typeCompatibIe(nodeType(n), tBoolean) THEN 
compError(’Boolean expression expected’); 

END; 

END boolCheck; 

PROCEDURE returnCheck(routine:symboI; expr;node):BOOLEAN; 

BEGIN 

IF (NOT nodeEmpty(expr)) AND (symbo1C I ass(routine) <> Func) THEN 
compError(’only functions can return values'); 

RETURN FALSE; 

ELSIF nodeEmpty(expr) AND (symboICIass(routine) <> Proc) THEN 
compError('function must return a value’); 

RETURN FALSE; 

ELSIF (NOT nodeEmpty(expr)) AND 

(NOT typeCompatibIe(symboIType(routine), nodeType(expr))) THEN 
compError(’return type not compatible with function type’); 
RETURN FALSE; 

ELSE 

RETURN TRUE; 

END; 

END returnCheck; 

BEGIN 

END TypeChecker. 


prolog.doc 

TEXT 

"AI in Computer Vision" John L Cuadrado and Clara Y. Cuadrado. 
January, page 237. Prolog.doc references Pdprolog.exe, which is 
available in the FromBYTE85 file area on BIX (PC/MS-DOS only). 


A.D.A PROLOG Documentation Version 1.7f for the Educational and Public 
Domain Versions October 28, 1985 Copyright Robert Morein and Automata Design 
Associates 1570 Arran Wav Dresher, Pa. 19025 (215)-646-4894 News Release 1.7f 
fixes the last bugs (heh). ANYONE who has ever purchased a copy of any 
version of A.D.A. PROLOG is entitled to a no-charge update. Simply send us 
your original disk or a photocopy of the receipt. We have included in pre¬ 
release form Simon Blackwell’s magnificent expert system shell. This system 
is tailored to A.D.A. PROLOG and includes forward and backward chaining, and 
a linkage method of insuring database consistency. Bayesian reasoning, rule 
editing, and documentation are forthcoming. The system was developed on VML 
PROLOG, but it is our intention to expeditiously insure that it runs under PD 
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PROLOG as well. To that end, we have added I/O redirection, 8 i nc ® '® how 

Simon stores things to disk. Copyright Notice The public domain PD PROLOG 
system has been contributed to the public domain for unrestricted use with 
one exception: the object code may not be disassembled ^ "lodified. 

Electronic bulletin boards and SIG groups are urged to aid in giving this 
software the widest possible distribution. This documentation may be 
reproduced freely, but it may not be Included in any other documentation 
without the permission of the author. Introduction We are pleased to 
present the third major version of PD PROLOG, version 1.7. Version 1.7 
continues to refine "problems" and adds the entertaining feature of IBM PC 
video screen support. The memory requirements are somewhat greater than the 
oriqinal, since it is uses the large memory model. It compensates in 
thoroughness. The memory requirement is about 210K bytes of TPA, and it wi 
benefit from up to 253k bytes. The ovailolble workspace is 100K bytes. We 
S^e that ™u’ll get some fun out of this PROLOG It will af or you exposure 
to THE fifth generation language at the cost only of some "?t 8l ' ec ‘ u81 , 

effort. The motive is perfectly explicable: We want you to think of Automata 
Design Associates for fifth generation software. It also gives us a nice worm 
feelina The memory requirement is 200 k of transient program area, P lus 
whatever space is needed to execute programs from within PROLOG DOS or MSDOS 
2 0 are required. The program does not require IBM PC compatibility to run, 
although the screen access routines do require compatibility. Pr0< ? uc ^ 8 
Automata Design Associates Automata Design Associates s P e8 ' 8l '^ es in software 
for artificial intelligence and robotic appIications. A PROLOG language 
system is available in various configurations. A LISP interpreter wiI be 

introduced in March of 1985. There are five vers 1008 1 ° f M cnos Sr°PCDOS 
Automata Design Associates. All of them run under the MSDOS or PCDOS 
operating systems. Other environments will be supported soon. .Public Domain 
PROLOG This serves to further the general awareness of the public about 
PROLOG It also is an excellent adjunct to anyone learning the language. Most 
of the core PROLOG described by Clocksin and Mellish in the book Programming 
In PROLOG is implemented. A complete IBM PC video screen support library is 
Included in this and all other A.D.A. prologs. Trace predicates are not This 
version is available from us for $10.00 postoge paid. .Educational PROLOG At 
extremely modest cost this affords on educational institution or individual a 
PROLOG system which provides the maximum available programming area aval la e 
within the 8086 small programming model. Tracing, a debugging aid, allows 
monitoring a program as it runs. User settable spy points selectively allow 
this Exhaustive tracing is also available. I/O redirection gives some file 
ability. An "exec" function allows the execution of a program or editor from 
within PROLOG, thus encouraging an interactive environment. An interrupt 
menu is added, permitting the control of tracing, toggling the printer, and 
screen printing. Definite clause grammar support is now included. The °\ 

Educational PROLOG is $29.95. .FSM PROLOG A small increment in price adds full 
random access file capability. Character and structure I/O are a lowed. The 
"asserta and "assertz" predicates are expanded and work with a clause 
indexing ability. One can assert clauses anywhere in the database under 
precise pattern matching control. A tree structured 1e ^ 80 ‘ ^°Pl n 9® y ®J* lOG 
and floating point arithmetic are other enhancements. The cost of FSM PROLOG 
is $49.95 .VMI PROLOG — Virtuol Memory (Replaces type VMS) At reasonable cost 
the addition of virtuol memory gives an expansion of capabilities of on order 
of magnitude. The database on disk Is treated transparently. No special 
provisions need be made by the user. Virtual and resident databases # b * 
mixed. A unique updating algorithim preserves the format of the database as 
typed by the user while making only those changes nec ® ss8r y ? 

equivalent to the database in central memory The cost of VMI PROLOG is 
$99 95 VML PROLOG Large model Virtual Memory System A.D.A. PROLOG is a 
remarkable fifth generation developement tool for . th ® !!" p ! '' 

intelligent strategies and optimized control. It is both the kerne for 
applications of virtually unlimited scope and a sophisticated developement 
tool that multiplies the productivity of the programmer many times. With a 
cost/performance ratio exceeding that of any other product an ‘‘ ° . 

comDatibiIity insured by compliance to the Edinburgh syntax, performance is 
enhanced by numerous extensions, many of them invisible to the ^ser. A quic 
overview of some of the features discloses: 1) Invisible c0, " p ' lat '° n ° 
semantic network preserves the flexibility of the interpreted mode and the 
speed of a compiler. The programmer con compile and recompile any portion of 
a module at any time. The edit/compile/test cycle is short ond free of 
strain. An interface is provided to an editor of choice. 2) Floating point 
arithmetic with a full complement of input and output methods, transcendental 
and conversion functions. 3) Virtuol memory. Module size and number is 
unrestricted. Resident and virtual modules may be coresident. Compilation 
incremental. The cache algorithim is sophisticated. Changes made in the 
database con be updated to disk by a single command. 4) A powerful exec 
function, and acceptance of stream Input make integration into applications 
practical. 5) Many additional built-in predicates enhance the efficiency of 
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the system. 6) Debugging facilities let you see your program run without any 
additional generation steps. 7) Totally invisible and incremental garbage 
collection. There is NEVER any wait for this function. The cost of this 
system is $200 for the MSDOS version. Upgrade Policy Half the cost of any 
A.D.A. PROLOG interpreter may be credited to the purchase of a higher level 
version. The full cost of VMS prolog may be applied to the purchase of VMI or 
VML PROLOG. Updates to a particular level product vary from $15.00 to $35.00. 

Run-time Packages Software developers wishing to integrate an A.D.A. product 
into their system should inquire about specialized run-time packages 
available at reasonable cost. Technical Information Technical information may 
be obtained at (215) - 646- 4894 Perhaps we can answer the following questions 
in advance: There is no support for: APPLE II, Atari, Commodore, or CPM 80 . 

Other machines from these manufactures may be supported in the future. The 
MSDOS products are available on 5" and 8" diskettes. To Place Your Order: You 
may place your order at the following number: (215)-646-4894 - day and night. 

Returns The software may be returned within 30 days of purchase for a full 
refund. This applies whether or not the software has been used. We do ask 
that manuals, disks and packaging be returned in excellent condition. How to 
run the Demonstration Programs without Knowing What You're Doing We strongly 
advise that you purchase the book Programming in PROLOG by Clocksin and 
Mellish, publisher Springer Verlag, 1981. For the impatient we give some 
advice. Type the demonstration program you wish to run. There must be at 
least one entry point within the program. Note: Please understand that these 
are demonstrations programs. Regarding user interface, they are poorly 
written. You will probably have to read Clocksin and Mellish to appreciate 
that the following examples of input are not equivalent: "yes." , "yes" . The 
animals program - "animal" Most of the examples require C & M for 
comprehension. The program "animals", however, can be appreciated by anyone. 

It is a traditional example of an expert system. We had hoped to include the 
animals program on disk, but we have found to our dismay that the version 
which we used is allegedly copyrighted by the implementors of PROLOG 86. 

Don't be surprised - even "happy birthday" is copyrighted. We will simply 
point out that the November *84 issue of Robotics Age included a version of 
the animals game, which you can, at the risk of copyright infringement, type 
in. There is only one change that need be made. The "concat" function used in 
that program has arguments of the form: concat( [atoml, atom2,...], result ). 

In order to make the concat definition more closely resemble that of "name", 
which is described by Clocksin and Mellish, the argments have been reversed: 
concat( result, [atoml, atom2,...] ) Assuming that you have typed in the 
program and made the change just noted, the following steps are required to 
run it: Run the prolog.exe file. The prompt "?-" will appear. Type "consult( 

'animals' ).<CR>". Here <CR> indicates you are to type a carriage return. The 
PROLOG system will load "animals" and compile it into an internal form. When 
the "?-" prompt appears PROLOG is ready to run the "animals" guessing game. 

The object of the program is to deduce the animal you are thinking of. To 
start it off type "help.<CR>". PROLOG will respond by asking a question. 

Because of the way the animals program is written, you must respond in a 
rigid format. You may type "yes<CR>", "no<CR>", or "why<CR>". Eventually the 
program will terminate with either a guess as to what animal you are thinking 
of, or a remark that the animal is not within its domain of knowledge. The 
program has learned, however. You may run the program again to see what 
effect additional knowledge has on the program’s behavior. The program 
fragment "console" shows how you may improve the console input routines of 
any of these programs. The Hematology Diagnosis Program - "hemat" Although 
the logical structure is not as sophisticated as that of "animals", it is 
interesting for several reasons: 1) The program evaluates numerical data to 
arrive at a diagnosis. 2) Although inaccurate, it demonstrates that useful 
question answering systems are not difficult to write in PROLOG. 3) There are 
some mistakes in the program, which only slightly impede its usefulness. 

This program uses structure input. Terminate all your answers with a period, 
as in "y.<CR>", or "no.<CR>". The starting point is "signs.<CR>". PROLOG will 
prompt you for signs of anemia. The program attempts to diagnose two 
varieties of a hemolytic anemia. The program could use a good working over by 
a hematologist and we would be delighted to collaborate. Prime Number 
Generator - "sieve" This program demonstrates that anything can be programed 
in PROLOG if one tries hard enough. Asking the question "primes( 50, L 
).<CR>" causes a list of prime numbers less than 50 to be printed out. 

"Sieve" is heavily recursive and quickly exhausts the stack space of the 
small model interpreters. Grrules This is an example of the use of the 
definite clause grammer notation. PD PROLOG does not have this translation 
facility, but ED PROLOG and all of our other versions do. It is possible to 
perform the translations by hand If you have thoroughly read C Sc M. Then you 
would have the pleasure of asking: ?-sentence( X, [every,man,Ioves,a,woman], 

[] ). and having the meaning elucidated as a statment in the predicate 
calculus. Special Offer # 1 For some inexplicable reason, demonstration 
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progroms are hard to come by. We are too busy writing PROLOG fill this gap. 

We wi I reward the contribution of "cute" sample progroms with the 
following: 1) A free copy of type VMS virtual memory PROLOG 2) The sample 
program w II be published as an Intact file together with whatever comments 
or advertlsments the outhor may see fit to Include, on our distribution disks. 

i) Exceptional contributions may merit a copy of type VML large model 
virtual memory PROLOG which now Incorporates a UNIX1 style tree structured 
domain *y*t*m« Special Offer # 2 If you ore a hardware manufacturer and would 
like a PROLOG language for your system, the solution is simple. Just send us 
one of your machines! Provided your system Implements a "C" compiler, it will 

ED PROLOG Y«„ n L t ! m ? I lat *, - K Tr ? d «»>ork AT & T. Writing Progroms For 

ED PROLOG You do not type In progroms at the prompt. There is no built- 

T ^ e comn ' and consu 11( user )" is accepted but does not cause 
PROLOG to enter on editing mode. We feel that the most universally acceptable 
editing method B th « us « r use a text editor of choice, which can be 

invoked from within PROLOG by the "exec" predicate. Use Wordstar or your 
customary editor to write a program. Then run PD PROLOG and use the consult 
function to load the program. In all cases except PD PROLOG, you con run your 
editor without leaving PROLOG by use of the "exec" predicate. Running the V 
Interpreter COMM A NDS.- Give commands in lower case. TO RUN: Invoke PROLOG.EXE 
After the ?- prompt appears, type "consult( <fiIename><CR> )", where 

! s J he desired database. To exit, type M exi tsys .<CR>" TO ASK A 
QUESTION. At the prompt, type "<expression>.<CR>", where <expression> is a 
question as described by Clocksin and Mellish. Be sure to terminate the 

The d ues tion may be up to 500 characters long. TO 
INPUT A STRUCTURE AT THE KEYBOARD: The structure may be up to 500 characters 
in length. Be sure to terminate with a period. TO ASK FOR ANOTHER SOLUTION- 
' * 8 ° lu "r b ? 8 Prid'd, the PROLOG interpreter will ask "More? 

ABORTYrfargh ? 1® ty ?! d 1 1 the inter P r «t«r perform a search. TO 

ABORT A SEARCH: Simply type the escape key. The interpreter will respond with 
interrupted. . and return to the command prompt. TO LOAD ANOTHER DATABASE: 
ype consuIt(<fiIename>).<CR>" The file name must have the extension " PRO" 
It is not necessary to include the extension in the argument of consult! The’ 
file name as given must not be the same as a predicate name in the file or 
any fiIe which wiI I be loaded. TO REMOVE A DATABASE: Type 

"forget(<filename>) ; <CR>" TO EXIT TO THE OPERATING SYSTEM: Type "ex 1tsys,<CR>" 
e system is totally interactive; any commands the operator gives ore and 
must be valid program statements. Statements must terminate with a period. 

is no+ m n a Cn?iH h pprti ftr k * * f '1® a1s0 accept a path name. Any name which 

is not a valid PROLOG atom (refer to C & M) must be enclosed In single 

quotes. Thus one could say consult( expert ) but one would need single quotes 
with consult( b:\somples\subtype\expert* ). To exit the system, type 
exitsys.<CR> Atoms may contain MSDOS pathnames if they are enclosed by 

8 l n9 +in,» UO u® 8 ’ *" ‘\ b: \ 8am P | ««\anlmal ’ . You may consult more than one file 

at a time. However, all names are public and name conflicts must be avoided. 

IffAr+ de thi n h W K IC ^ m °~ u ® 8 are loaded may, in cases of poor program design, 
affect the behavior. Command Line Arguments ED PROLOG accepts one command 
ine argument, which s the name of a "stream" which replaces the console for 
mput The stream" in MSDOS is a pipe or file which supplies input unt it 
end-of-file is reached. Control then reverts back to the console. To avoid 

?hi S fi^ rS ! r r SS ? 9 ® 8 wh8n «"d-of-flle is reached, the last command in 

the file should be see( user )." A Reference of Note With minor exceptions, 
the syntax is a superset of that described by Clocksin and Mellish in the 
book Programming n Prolog by W.F. Clocksin and C.S. Mellish. published by 
Springer Ver la 9 i * n BerI in. Heidelberg, New York, and Tokyo. We shall refer 
to this book as C & M . There are very few syntactical differences, mostly 
unrecognized and/or minor. When an operator is declared using the "op" * 
statement, the operator must be enclosed in single quotes in the "op" 
statement itself, if it would not otherwise be a legal Edinburgh functor. 
Subsequently however, the parser will recognize it for what it is, except in 
the unop statement, where it must again be enclosed in single quotes. 
Variable numbers of functor paramaters are supported. A goal may be 
represented by a variable, which is less restrictive than the C & M 
requirement that all goals be functors. The variable must be instantiated to 
a functor when that goal is pursued. Rules which appear inside other 
expressions must be enclosed in parenthesis if the operator is to be 
recognized as a logical connective. All infix operators described by C & M 
and user defined infix, prefix, and postfix operators with variable 
associativity and precedence are supported exactly as in C & M. The Built In 
Predicate Library Available Operators in PD and ED PROLOG Column 1 gives the 
function symbol Column 2 gives the precedence. The range of precedence is 1 
to 255. A zero in the precedence column indicates the symbol is parsed as a 
functor, and precedence is meaningless in this case. Column 3 gives the 
associativity. A zero in the associativity column indicates the symbol is 
parsed as a functor, and associativity is meaningless in this case. Column 4 
indicates which version the function is available in. Unless otherwise noted, 
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the function is available in all versions. Nonstandard predicates are 
indicated by "NS", op/pred precedence associativity availability "!" 0 0 "|" 0 
0 40, XFX "—" 40, XFX "\\«" 40, XFX "\\==" 40, XFX "/" 21. YFX "@=" 

40, XFX ">=" 40, XFX "=<" 40, XFX ">" 40, XFX "<" 40, XFX "-" 31, YFX 
"*" 21, YFX "+" 31, YFX 40, XFX 255, YFY (not in PD PROLOG) "?-" 

255, FY "arg" 0, 0, "asserta" 0, 0, "assertz" 0, 0. "atom" 0, 0, 

"atomic" 0, 0, "clause" 0, 0, "clearops" 0, 0, "els" 0, 0, NS "concat" 0, 

0, "consult" 8, FX, "crtgmode" 0, 0, NS "crtset" 0, 0, NS "curset" 0, 0, NS 
"curwh" 0, 0, NS "debugging 0, 0, "dir" 0, 0, "display" 0, 0, "dotcolor" 0, 

0, NS "drawchar" 0, 0, NS "drawdot" 0, 0. NS "drawline" 0, 0, NS "exec" 0, 0, 

"exitsys" 0, 0, NS "forget" 0, 0, NS "functor" 0, 0, "get0" 8, FX, 

"integer" 0, 0, "is" 40, XFX, "listing" 0, 0, "mod" 11, XFX, "name" 0, 0, 

"nl" 0, 0, "nodebug" 0, 0, (not in PD PROLOG) "nonvar" 0, 0, "nospy" 50, FX, 

(not in PD PROLOG) "not" 60 FX "notrace" 0. 0, (not in PD PROLOG) "op" 0, 0, 

"popoff" 0, 0. NS "popoffd" 0, 0, NS "popon" 0, 0, NS "popond" 0, 0, NS 

"print" 0, 0, "prtscr" 0, 0, NS "put" 0, 0, "ratom" 0, 0, "read" 0, 0, 

"recon" 0, 0, (Note: this is "reconsuIt") "repeat" 0, 0, "retract" 0, 0 

"rnum" 0, 0, "see" 0, 0, (not in PD PROLOG) "seeing" 0, 0, (not in PD PROLOG) 

"seen" 0, 0, (not in PD PROLOG) "skip" 0, 0. (not in PD PROLOG) "spy" 50, FX, 

(not in PD PROLOG) "tab" 0, 0. "tell" 0, 0, (not in PD PROLOG) "telling" 0. 

0, (not in PD PROLOG) "told" 0, 0, (not in PD PROLOG) "trace" 0, 0, (not in PD 
PROLOG) "true" 0, 0, "unop" 0, 0, "var" 0, 0, "write" 0, 0, Description of 
the Modifications. call( <goal> ) The predicate as defined in C & M is 
obsolete. The purpose was to permit a goal search where the goal name was a 
variable instantiated to some functor name. A.D.A. permits writing of goals 
with such names, so the mediation of the "call" clause is no longer 
necessary. The "call" predicate may be trivially implemented for 
compatibility with the PROLOG definition caI I( X ) :- X. clause The function 
clause( X, Y ) has the new optional form clause( X, Y, I ). If the third 
variable is written, it is instantiated to the current address of a clause in 
memory. The only use of the result is with succeeding assertfa and assertfz 
statements, debugging "Debugging" prints a list of the current spypoints. 

After each name a sequence of numbers may appear, indicating the number of 
arguments that is a condition of the trace. The word "all" appears if the 
number of arguments is not a condition of the trace. op( <prec>, <assoc>, 

<functor> ) Defines the user definable grammar of a functor. The definition 
conforms to that In C k M. We mention here a minor but important point. If 
<functor> is not a valid PROLOG atom it must be enclosed in single quotes 
when declared In the "op" declaration. It is not necessary or legal to do 
this when the functor is actually being used as an operator. In version 1.6, 
a declared or built-in operator can be used either as an operator or as a 
functor. For example, +(2,3) « 2 + 3. is a true statement. Declared operators 
are annotated in the directory display with their precedence and 
associativity. Output predicates display write print put These functions have 
been modified to accept multiple arguments in the form: print( <arg1>, 

<arg2>, <arg3>,... ) Thus, "put( a, b, c )" would result in the display of 
"abc". The names of some PROLOG atoms that may occur are not accepted by the 
PROLOG scanner unless surrounded by single quotes. This only applies when 
such an atom is read in, not when it is internally generated. Nevertheless, 
this presents us with a problem: We would like to be capable of writing valid 
PROLOG terms to a file. In some cases, it is necessary to add the single 
quotes. In other cases, such as human oriented output, they are an irritant. 

The modified definitions of the following predicates are an attempt at a 
solution: display Operator precedence is ignored, all functors are printed 
prefix and single quotes are printed if needed or they were supplied if and 
when the atom was originally input, write Operator precedence is taken into 
account and operators are printed according to precedence. Single quotes are 
printed under the same conditions as for "display." print Operator precedence 
is taken into account and operators are printed according to precedence. 

Single quotes are never displayed. This is a human oriented form of output 
and should never be used for writing of terms for the PROLOG scanner. get0 
read The functions "get0" and "read" have been extended to support input from 
a stream other than the one currently selected by "see". To direct output to 
a file or other stream, an optional argument is used. For example, "get0( 
char, <flle name> )" or "get0( char, user )" would cause Input to come from 
<file name> or the console. If the file has not already been opened, "get0" 
will fall. Atoms enclosed by single quotest, eg. *\nthis is a new line* can 
contain the escape sequences '\n', *\r*, '\t* and * V * . If these atoms are 
printed by "display" or "write" they are printed just as they are. If they 
are printed by the "print" clause they are translated as follows: *\n* 
results in the printing of a carriage return and a line feed. '\r* results in 
the printing of a carriage return only. *\t* results in the printing of a tab 
character. allows the printing of a single quote within a quoted atom. 

The "portray" feature is not presently implemented. Description of the New 
Predicates clearops- Nullify the operator status of every operator in the 

(continued) 
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database. concat( (<varlable> | <functor>), <Ust> ) A list of functors or 
operators is concatenated into one string, which becomes the name of a new 
atom to which <variable> or <functor> must match or be instantiated. dir( 
option ) Provide an alphabetized listing to the console of atoms, constants, 
or open files. Without options, simply type "dir.<CR>". Options are: dir( 
pred ) - list clause names only, dir( files ) - list open files only, exitsys 
Exit to the operating system. forget( <file name> ) Make a database 
unavailable for use and reclaim the storage it occupied. ratom( <arg>, 
<stream> )- Read an atom from the input stream, to which <arg> matches or is 
instantiated. <stream> is optional. If <stream> is not given, the input 
stream defaults to the standar input. Input is terminated by a CR or LF, which 
are not included in the stream. Arithmetic Capabilities Integer arithmetic is 
supported. Numbers are 32 bit signed quantities. The following arithmetic 
operators are supported: "/", <, <-, >, >«, mod. Arithmetic 

operators must never be used as goals, although they may be part of 
structures. It is legal to write: X « a + b which results in the 
instantiation of X to the struture (a + b). But the following is not legal: 
alpha( X, Y ) :- X + Y, beta( Y ). Evaluation of an arithemtic expression is 
mediated by the “is" and inequality predicates. For instance, the following 
would be correct: alpha( X, Y, Z ) :- Z is X + Y. beta( X, Y) :- X + 2 < Y + 
3. IBM PC Video Display Predicates A high level method is provided for drawing 
and displaying on the screen of IBM PC and compatible computers, els Clear 
the screen and position the cursor at the upper left hand corner. crtgmode( X 
) Matches the argument to the mode byte of the display which is defined as 
follows: mode meaning 0 40 x 25 BW (default) 1 40 x 25 COLOR 2 80.x 25 BW 3 80 
x 25 COLOR 4 320 x 200 COLOR 5 320 x 200 BW 6 640 x 200 BW 7 80 x 25 
monochrome display card crtset( X ) This sets the mode of the display. The 
argument must be one of the modes given above. curset( <row>, <column>, 
<page> ) Sets the cursor to the given row, column, and page. The arguments 
must be Integers. curwh( <row>, <column> ) Reports the current position of the 
cursor. The argument must be an integer or variable. The format is: 1) page 
zero Is assumed. 2) The row is In the range 0 to 79, left to right. 3) The 
column is in the range 0 to 24, bottom to top. dotcolor( <row>, <column>, 
<color> ) The argument <color> Is matched to the color of the specified dot. 
The monitor must be in graphics mode. drawchar( <character>, <attribute> ) Put 
a character at the current cursor position with the specified attribute. The 
arguments <character> and <attribute> must be integers. Consult the IBM 
technical reference manual regarding attributes. drawdot( <row>, <column>, 
<color> ) Put a dot at the specified position. The monitor must be in the 
graphics mode. The arguments must be integer. The argument <color> is mapped 
to integers by default In the following manner: drawline( <X1>, <Y1>, <X2>, 
<Y2>, <color> ) Draw a line on the between the coordinate pairs. The monitor 
must be in the graphics mode and the arguments are integer, prtscr Print the 
screen as it currently appears. Be sure that the printer is on line and ready 
before invoking this predicate, since otherwise, the system may lock up or 
abort. The integer argument <color> referred to in the above predicates is 
represented as follows: COLOR PALETTE 0 PALETTE 1 0 background background 1 

green cyan 2 red magenta 3 brown white To change the palette and the 
background, see the IBM Technical Reference Bios listings for more 
information. Trace Files (type ED only) You can now dump your trace to disk, 
instead of (groan) wasting reams of printer paper. This option is described 
in the next section. The Interrupt Menu (type ED only) This menu has been 
modified. It was formerly called the ESCAPE menu, but the meaning of the 
ESCAPE key has been redefined. It is no longer necessary to display the menu 
to perform one of the menu functions. This reduces the amount of display 
which is lost by scrolling off the screen. At any time while searching, 
printing, or accepting keyboard input, you can break to this menu. It is 
generally not possible to do this during disk access, since control passes to 
the operating system at this time. Two keys cause this break to occur: ^V: 
The menu is displayed and a command is accepted at the prompt "INTERRUPTS'. 
After a command, the menu is redisplayed until the user selects a command 
which causes an exit. *1: The menu Is not displayed. Command is accepted at 
the prompt "INTERRUPTS' until the user selects a command which causes an 
exit. ESC: Typing this key causes a termination of the PROLOG search and 
control returns to the user command level with a prompt of Notice that 

previously, the ESC key invoked this menu. As the resulting menu indicates, 
the following functions are possible: A: Abort the search and return to the 
prompt. 0 Open a trace file. The user is prompted for the file name. The file 
receives all trace output. If a file is already opened it is closed with all 
output preserved. C Close the trace file if one is open. Otherwise there is 
no effect. ^C: Immediately exit PROLOG without closing files. This is not 
advised. ~P: Typing <Control>P toggles the printer. If the printer is on, all 
input and output will also be routed to the printer. S: If the machine in use 
is an IBM PC compatible machine, the currently displayed screen will be 
printed. If the machine is not an IBM PC compatible, do not use this 
function. T: If trace is in use, most of the trace output can be temporarily 
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turned off by use of this function, which is a toggle. R: Entering another 
ESC causes a return to the current activity (keyboard input or search) with 
no residual effect from the interruption. Conserving memory space Success 
popping is controlled by the predicates "popond", "popoffd", "popon", and 
"popoff". Success popping is means of reclaiming storage which is used on 
backtracking to reconstruct how a particular goal was satisfied. If it is 
obvious that there is no alternative solution to a goal this PROLOG system is 
smart enough to reclaim that storage. In this system, succees popping is an 
expensive operation. Therefore, there is a tradeoff of memory versus time. On 
the other hand, discrete use of success popping can actually speed up a 
program by recreating structures in a more accessible form. The definitions of 
the control predicates is given in this manual and their use is totally 
optional. The modulation of success popping has no effect on program logic 
(read solution.) The "cut" can save substantial time and computational 
overhead as well as storage. Although the execution of the cut costs time, 
you can design your program to use cuts in critical places to avoid 
unnecessary backtracking. Thus the execution speed of the program can 
actually increase. Anyone who has read Cfocksin and Mellish is aware, of 
course, that the "cut" has a powerful logical impact which is not always 
desirable, popoff See the below definition, popon The inference engine does 
complete success popping for goals which appear after "popon". Consider this 
example: goal a, popon, b, c, popoff, d. If no alternative solutions exist 
for b, then success popping will reclaim storage by removing unnecessary 
records describing how "b" was satisfied. If the Prolog system cannot rule 
out possible additional solutions, success popping will never occur, 
regardless of your use of "popon". Since goal "d" occurs after "popoff", 
success popping will never occur, popoffd If no "popon" or "popoff" 
declarations occur in a clause, the default action is determined by "popoffd" 
and "popond". If "popoffd" has been invoked, the default is that success 
popping will not occur, popond The inverse of "popoffd". Turns on default 
success popping. printf( <stream>, <term1>,<term2>,... ) Prolog Tutorial 
Introduction Probably you have heard of the language PROLOG within the last 
year or so. You probably wondered the following things: 1) What does the name 
stand for? Names of computer languages are almost always acronyms. 2) What is 
it good for? 3) Why now? 4) Can I get a copy to play with? Congratulations! 

You obviously know the answer to the fourth question. We now respond to the 
other three. 1) The name stands for "programming in logic." This we shall 
elaborate on in depth later on. 2) PROLOG is good for writing question 
answering systems. It is also good for writing programs that perform 
complicated strategies that compute the best or worst way to accomplish a 
task, or avoid an undesirable result. 3) PROLOG was virtually unknown in this 
country until researchers in Japan announced that it was to be the core 
language of that country’s fifth generation computer project. This is the 
project with which Japan hopes to achieve a domainant position in the world 
information industry of the 1990’s. PROLOG is one of the most unusual 
computer languages ever invented. It cannot be compared to FORTRAN, PASCAL, 

"C", or BASIC. The facilities complement, rather than replace those of 
conventional languages. Although it has great potential for database work, it 
has nothing in common with the database languages used on microcomputers. 

Perhaps the best point to make is that while conventional languages are 
prescriptive, PROLOG is descriptive. A statement in a conventional language 
might read: jf( cartwheels ■ TRUE ) then begin (some sort of procedure) X = X 
+ 1; end A statment in PROLOG could just be a statment of fact about cars 
and wheels. There are many relationships that hold. For instance, has( car, 
wheels ). has( car, quant(wheeIs, four) ). round( wheels ). Each of these 
statments is an independent fact relating cars, wheels, and the 
characteristics of wheels. Because they are independent, they can be put into 
a PROLOG program by programmers working separately. The man who is a 
specialist on car bodies can say his thing, the wheel specialist can have his 
say, and the participants can work with relative independence. And this 
brings to light a major advantage of PROLOG: PARALLEL PROGRAMMING!!! With 
conventional programming languages projects can still be "chunked", or 
divided between programmers. But efficiency on a team project drops 
drastically below that of the individual programmer wrapped up in his own 
trance. As the number of participants grows the need for communication grows 
geometrically. The time spent communicating can exceed that spent 
programming! Although PROLOG does not eliminate the need for task 
coordination, the problem is considerably simplified. It also provides the 
ability to answer questions in a "ready to eat form." Consider your favorite 
BASIC interpreter. Based upon the statements about cars and wheels previously 
given, could you ask It the following question? has( car, X ), round( X ). 

Does a car have anything which is round? The question instructs the PROLOG 
interpreter to consider all the objects that It knows are possessed by a car 
and find those which are round. Perhaps you are beginning to guess that 
PROLOG has the abilities of a smart database searcher. It can not only find 
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the facts but selectively find them and Interpret them. Consider the prob em 
of a fault tree, as exemplified by this abbreviated one: {Car won t start* | 

I [Engine turns over](No) —> [Battery voltage](no)-\ (Yes) v | [Check 
battery* | [Smell gasolIne](yes) —> [Try full thrott e cranking* | (failure) 

/_/ I (detaiIs omitted) The fault tree is easily programmed In BASIC. 

Later we shall show that PROLOG supplies a superior replacement for the fau t 
tree Though the tree is capable of diagnosing only the problem for which it 
was designed, PROLOG dynamically constructs the appropriate tree from facts 
and rules you have provided. PROLOG is not limited to answering one specific 
question. Given enough Information, it will attempt to find all deductive 
solutions to any problem. PROLOG PRIMER I. Rules ond Facts This is where you 
should start if you know nothing about PROLOG. Let us consider a simple 
statment in PROLOG, such as: 1) has( car. wheels ). This statement is a tact. 
The word "has" in this statment is known either os a functor or predicate. It 
is a name for the relationship within the parenthesis. It mplies that a car 
has wheels. But the order of the words inside the bracket is arbitrary and 
established by you. You could just as easily soy: 2) hos( wheels, car )• 

If you wrote this way consistently, all would be well. The words has, wheels, 
and car are all PROLOG atoms. "Wheels" and "car" areconstants. A database 
of facts con illustrate the data retrieval capabilities of PROLOG. For 
instance: 3) has( car, wheels ). has( car, frame ). has( car, windshield ). 
hos( car, engine ). You could then ask PROLOG the ques*i°n: 4> ha s ( car. Part 
) The capital "P" of Part means that Part is a variable. PROLOG will make 
Part equal to whatever constant Is required to moke the question match one of 
the facts in the database. Thus PROLOG will respond: Port - wheels. 

More?(Y/N): If you type "y" the next answer will oppeor: Part - frame. 
More?(Y/N): If you continue, PROLOG will produce the answers Part - windshield 
and Port = engine. Finally, you will see: More?(Y/N):y No. Indicating that 
PROLOG has exhausted the database. Incidentally, when a variable is set equal 
to a constant or other variable, it is said to be Instantiated to that 
obiect. Notice that PROLOG searches the database forwards and in this case, 
from the beginning. The forward search path is built Into PROLOG and cannot 
be changed. An author of a program written in a prescriptive angu<»g« '• 
quite conscious of the order of execution of his program, wh le in PROLOG t 
is not directly under his control. The other major element is the rule which 
is a fact which is conditionally true. In logic this is called a Horn clause: 
5) has( X, wheels ) iscar( X ). The fact iscar( car ) and the above rule 
afi equlvoient to 6) has( car, wheels). The symbol :- is the.“rule sign." The 
expression on the left of :-ls the "head" and on the right is the body. The 
variable X has scope of the rule, which means that it has meaning only within 
the rule. For instance, we could have two rules in the database using 
identically named variables. 7) has( X. transportation ) ^as( X car ). 
has( license, X ). 8) has( X. elephant ) istrainer( X ). hasjob( X ).The 
variables X in the two expressions are completely distinct and hove nothing 
to do with each other. The comma between hos( X, car ) and has( icense,X ; 
means "and" or logical conjuction. The rule will not be true'unless b ?* h 
clauses has(X. car) and hos( license. X ) are true. On the other hand if there 
is a rule 9) hos( license. X ) passedexam( X ). consider what PROLOG will 
do in response to the question: 18) has( harry, transportation ). (Notice that 
harry has not been capitalized because we do not want it taken as 0 ?u| 

We could however, say ’Harry* enclosed in single quotes.) It will scan the 
database and use (7). in which X wlI I be instantiated to harry. The rule 
generates two new questions: 11) has( harry, car ) .12) has( ' c ®"*®’ 

Assuming that harry has a cor, the first clause of (7) is satisfied and the 

database is scanned for a match to (12). PROLOG picks up rule (9) in which X 

is instantiated to harry and the question is now posed: 13) passedexam( harry 
). If there is a fact: passedexam( harry ). in the database then all is well 
and harry has transportation. If there is not, then PROLOG will succinctly 
tell you: No. But suppose Harry has money and can hire a chauffer as any good 
programmer can. That could be made part of the program in the following way 

The rule which PROLOG tried to use was: 14) has( X, transportation ) :- ^as( 

X car ), has( license, X ). At any point following it there could be included 
another rule: 15) has( X, transportation ) :- has( X, money ). or simply the 
bald fact: 16) has( harry, transportation ). These additional rules or facts 
would be used in two circumstances. If at any point a rule does not yield a 
solution, PROLOG will scan forward from that rule to find another appIicab Ie 
one. This process is known as "backtracking search" and can be qu!te time 
consuming. If in response to the "More?" prompt you answer "y PROLOG wiI I 
search for an additional distinct solution. It will attempt to find an 
alternate rule or fact for the last rule or fact used. If that faiI:s, 1 1 wi 
back up to the antecedent rule and try to find an alternate antecedent. And 
it will continue to back up until it arrives at the question you asked, at 
which Doint it will say: No. "Antecedent" to a rule means that it gave rise 
to its* use. For example, (7) is the antecedent of (9) in the context of the 
question (16). II. Grammar Jt is a boring subject, but it must be discussed. 
All PROLOG statements are composed of valid terms, possibly a rule sign { 
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"), commas representing conjunction ("and"), and a period at the very end. A 
term is a structure, constant, variable, or number. What is a structure? It 
is a kind of grouping: 1) Structures consist of a functor, and a set of 
objects or structures in parenthesis. 2) Objects are constants, variables, 
numbers, or lists, which we have not discussed yet. 3) A constant or functor 
must be a string of letters and numbers, beginning with a lower case letter, 
unless you choose to enclose it in single quotes ( ’howdy pardner* ), in 
which case you are freed from these restrictions. 4) A variable must be a 
string of letters and numbers beginning with a capital letter. 5) A functor 
may optionally have arguments enclosed in parenthesis , as in: hascar( X ) or 
hascar. An example: "has( X, transportation )." is a structure. III. Input / 
Output You now know enough to write simple databases and interrogate them 
profitably. But before we examine more sophisticated examples, it will be 
necessary to add input and output to the language. There are built in 
functions which appear as rules which are satisfied once. Thus the statment: 
write( * He I Io world.* ). can be included on the right side of a rule: 
greetings( X ) :- ishuman( X ), write( 'Hello world.* ). You can also write 
"write( X )" where X is some variable. Note that ’Hello world.* is not 
enclosed in double quotes. Single quotes, which denote a constant, are 
required. Double quotes would denote a list, which is another thing entirely. 
Provided that a match to "ishuman" can be found, the builtin function "write" 
is executed and the message printed to the screen. The builtin read( X ) 
reads a "structure" that you input from the keyboard. More formally, we have 
read( <variable> or <constant> ) write( <variable> or <constant> ) If you 
write read( Input ), then the variable "keyboard" will be assigned to 
whatever is typed at the keyboard, provided that the input is a valid PROLOG 
structure. The builtin "read" will fail if instead of Keyboard we wrote read( 
baloney ), where "baloney" is a constant, and the user at the keyboard did 
not type exactly "baloney." When you input a structure in response to a 
"read" statement, be sure to end it with a period and an <ENTER>. There is a 
convenient way of putting the cursor on a new line. This is the builtin "nl". 
For example: showme :- write( *line 1* ), nl, write( ’line 2* ). would result 
in: line 1 line 2 There is also a primitive form of input/output for single 
characters. It will be discussed later. IV. A Fault Tree Example Consider the 
"won’t start" fault tree for an automobile: {Car won't start} | | [Engine 

turns over](No) —> [Battery voItage](no)-\ (Yes) v | {Check battery} | [Smell 

gasoline](yes) —> {Try full throttle cranking} | (failure) /-/ | | 

/-/ || III [Check for fuel line Ieaks](yes)— 

>{Replace fuel line} | (no) j j | | | TCheck for defective carburator](yes)—\ 

I (no) v I {Repair carburator} \-\ | | [Is spark present](no)—>[Do points 

open and close](no)-\ | (yes) v /-/ | {Adjust points} | 

/-/ | | | [Pull distributor wire, observe 

spark](blue)—\ | (orange) v j j {Check plug wires & cap} | | | [Measure 
voltage on coil primary](not 12V)—\ | (12V) v | | {Check wiring, ballast 
resistor} | | | [Check condenser with ohmmeter](conducts)—\ | (no conduction) 
v | | {Replace condenser} | | | [Open and close points](voItage not 0 - 12)—\ 
| (voltage swings 0 - 12) v | j {Fix primary circuit} | | | {Consider hidden 

fault, swap components] | | \-{Call a tow truckl!} A PROLOG program to 

implement this is simple. Each statment represents a decision point fragment 
of the tree. The PROLOG interpreter dynamically assembles the tree as it 
attempts a solution. ’car wont start* :- write( 'Is the battery voltage 
low?* ), affirm, nl, write( 'Check battery* ). 'car wont start' :- write( 
’Smell gasoline?' ), affirm, nl, ’fuel system*, 'fuel system’ write( 'Try 
full throttle cranking' ). ’fuel system' :- write( 'Are there fuel line 
leaks?' ), affirm, nl, write( 'Replace fuel line.’ ). ’fuel system’ :-write( 
'Check carburator’ ). 'car wont start* :- write( 'Is spark present?' ), not( 
affirm ), nl, 'no spark*, 'no spark' wrlte( ’Do points open and close?' ), 
not( affirm ), nl, write( 'Adjust or replace points.' ). 'no spark* :- write( 
’Is the spark off the coil good?’ ), affirm, write( ’Check plug wires and 
cap.' ). 'no spark* write( 'What is the voltage on the primary of the coil: 

' ), read( Volts ), Volts < 10, nl, write('Check wiring and ballast 
resistor.'), 'no spark' :- write( 'Does the capacitor leak?’ ), affirm, write( 
'Replace the capacitor.* ). 'no spark* :- not( ’primary circuit* ). 'primary 
circuit' :- write( 'Open the points. Voltage across coil?:'), nl, read( 
Openvolts ), Openvolts < 1, write( 'Close the points. Voltage across 
coil?:'), read( Closevolts ), Closevolts > 10, nl, write( 'Primary circuit is 
OK.' ). 'no spark' wrlte( 'Consider a hidden fault. Swap cap, 
rotor,points,capacitor.' ). 'Car wont start' write( 'Get a tow truck!!' ). 
—End program— The above is a simple example of an expert system. A 
sophisticated system would tell you exactly the method by which it has 
reached a conclusion. It would communicate by a "shell" program written in 
PROLOG which would accept a wider range of input than the "valid structure" 
required by the PROLOG interpreter directly. V. Lists Consider a shopping 
list given you by your wife. It is a piece of paper with items written on It 
in an order that probably symbolizes their importance. At the top it may say 
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EGGS!!! 
dog, if 
carrots, hamburger, 
and carrots cannot 


followed by carrots, hamburger, and finally a flea collar for the 
you can find one. In PROLOG such a list would be written: 1) [eggs, 

fleacollar] The order of a list is important so that eggs 
be reversed and PROLOG be uncaring. Let us put the list in 


a structure: shopping( [eggs, carrots, hamburger, fleacollar] ). Then if you 
wished to isolate the head of the list you could ask the question: shopping( 

[ Most important | Rest ] ). and PROLOG would respond: Most important * eggs, 
Rest - [carrots, hamburger, fleacollar]. The vertical bar "j" is crucial here. 
It is the string extraction operator, which performs a combination of the CDR 
and CAR functions of LISP. When it appears in the context [X|Y] it can 
separate the head of the list from the rest, or tail. You may have gained the 
impression that PROLOG is a rather static language capable of answering 
simple questions, but It is far more powerful than that. The string 
extraction operator is the key. It permits PROLOG to whittle a complex 
expression down to the bare remainder. If the rules you have given it permit 
it to whittle the remainder.down to nothing, then success is achieved. An 

example of this is the definition of "append." Let us suppose you have not yet 

done yesterday’s shopping, let alone today’s. You pull it out of your wallet 
and sootch tape it to the list your wife just gave you. Yesterday’s list was: 
[tomatoes, onions, ketchup] Combined with [eggs, carrots, hamburger, 
fIeacoliar] we 

otain[eggs,carrots,hamburger,fleacollar,tomatoes,onions,garlic]. To take one 
list and to attach it to the tail of another list is to "append" the first to 

the second. The PROLOG definition of append is: Rulel: appendf [], L, L ) 

Rule2: append( [X|List1]. List2, [X|List3] ) :- append( List 1. List2, List3 ]. 
The general scheme Is this: The definition consists of one rule and one fact. 
The rule will be used over and over again until what little is left 
the fact. The [] stands for empty list, which is like a bag without 
in it. This is an example of a recursive definition. Suppose we ask: 


a,b,c 
d, e, f 
d, e, f 
L i st3 
End. How 


matches 
anything 
append( 


( [a,b,c], 
[b.c]. 


[d.e.f], Whatgives ). 1. Rule 2 is invoked with arguments 
Whatgives ). 2. Rule 2 is invoked again with arguments: ( 

List3 ). 3. Rule 2 is invoked again with arguments: ( [b], [d.e.f], 
4. The arguments are now ([], [d.e.f], List3 ). Rule 1 now matches, 
does this cause a list to be constructed? The key is to watch the 
third argument. Supplied by the user, It is named “Whatgives". The inference 
engine matches it to [X|List3] in rule 2. Now lets trace this as rule two is 
successivly invoked: Whatgives | | | v Rule2: [X|List3l (listl = [b,c]) 

Lm\ l [Plu.u--'* (Us,r • !c)) - > V ! V J \ \ 

L ( in Rulel = 
reason: Notice that 
rule It invokes. So 


t3’ ’ ] 
.e.f] 


__ .cl] 

(Listl” - [], ie., empty set.) | \ | \ | \ Rulel: 

) End. L in rule 1 is [d,e,f] for the following 
rule 2 never alters List2. It supplies it to whatever 
in rule 1 is the original List2, or [a.b.c]. This 


example would not have worked if the order of rules one and two were 
reversed. The PROLOG inference engine always attempts to use the the first 
rule encountered. You could imagine it as always reading your program from 
the top down in attempting to find an appropriate rule. Since rule 2 would 
always satisfy, an unpleasant thing would have happened if the order were 
reversed. The program would loop forever. I hope that this tiny introduction 
to PROLOG whets your appetite. You should now purchase the book Programming 
In Prolog W.F. Clocksin and C.S. Mellish Springer - Verlag 
BerI in,Heidelberg,New York. 1981,1984 Springer - Verlag 
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L i netest.pas 

TEXT 

"Turbo Pascal 3.0" Mark Bridger. 

February, page 281 

program LINETEST; 

for i :* 0 to 15 do 

var 

for j :« 0 to 9 do 

1, j : integer; 

draw(20*i, 20*j, 319-20*i, 199-20*j, i+j) 

beg i n 

write(chr(7)) {Beep} 

graphmode; 

end. 

Pa 1ette(1); 


Btrans.pas 


TEXT 


"Turbo Pascal 3.0" Mark Bridger. 


February, page 281 


program BTRANS; 

while not(EOF(F)) do 

var 

beg i n 

F,G: file; {untyped files for blockmoves} 

blockread(F, buffer, 1,1); 

buffer: array[1..128] of byte; 

blockwrite(G, buffer, 1,1) 

I: integer; 

end; 

beg i n 

close(F); close(G); 

assignfF, * infile.dat 1 ); 

wr ite(chr(7)); {Beep} 

assign(G, ’outfile.dat’); 

end. 

reset(F); rewrite(G); 


Trans.pas 


TEXT 


"Turbo Pascal 3.0" Mark Bridger. 


February, page 281 


program TRANS; 

while not(EOF(F)) do 

var 

beg i n 

F*,G: file of byte; 

read(F, ch); 

ch: byte; 

wrlte(G, ch) 

begin 

end; 

assignfF, * inf I1e.txt *); 

close(F); close(G); 

assign(G, ’outfi1e.txt'); 

write(chr(7)); {Beep} 

reset(F); rewrite(G); 

end. 

Ca1c.pas 


TEXT 


"Turbo Pascal 3.0" Mark Bridger. 


February, page 281 


program CALC; 

beg i n 

var A,B,C: rea1; 

C:- C * A; 

N, I: integer; 

C:- C * B; 

beg i n 

C:- C/A; 

N:- 5000; 

C:- C/B 

A:- 2.71828; 

end; 

B:« 3.14159; 

wr i te(chr(7)); 

C:» 1; 

write1n(’Error ■ C - 1) 

For I:« 1 to N do 

end. 


( continued ) 
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Float.pas 

TEXT 

"Turbo Pascal 3.0" Mark Brldger. 

February, page 281 

program FLOAT; 

y:- ln(x); 

var I: integer; 

y:« exp(x); 

x.y: real; 

y:« sqrt(x); 

beg I n 

y:* arctan(x); 

x:» 1; 

x:* x + 0.01 

for I:- 1 to 1000 do 

end 

beg i n 

end. 

y:- sin(x); 


Sieve.pas 


TEXT 


"Turbo Pascal 3.0" Mark Bridger. 


February, page 281 


program SIEVE; 

then 

const 

begin 

size - 8190; 

prime:* I + I +3; 

var 

k:« I + prime; 

flags: array[0..size] of boolean; 

wh11e K <* size do 

I, prime, K, count, iter: integer; 

begin 

begin 

flags[K]:* false; 

wr iteln(*Start one iteration.*); 

K:* K + prime; 

for iter:* 1 to 10 do 

end; 

begin 

count:* count + 1 

count:* 0; 

end; 

for I:* 0 to size do 

wr i te1n(count:1,' primes.*); 

flags[I]:* true; 

end; 

for I:* 0 to size do 

writeln(chr(7)) {Beep} 

if flags[I] 

end. 

Qsort.pas 


TEXT 


"Turbo Pascal 3.0" Mark Bridger. 


February, page 281 



Eprogram Quicksort(input.output); 
const 

max = 100; 
type 

standardArray * array[0..max] of real; 
var 

numbers: standardArray; 
last: integer; 

procedure swap(var a,b ; real); 
var 

t : reaI; 
beg i n 
t :* a; 
a :* b; 
b := t; 
end; 

procedure prIntArray(top : integer); 
var 

i : integer; 
begin 

writ eIn(*-MARK-*); 
end; 

procedure getArray(var top:integer); 
const 

worstCase : standardArray = 

(100.0, 99.0, 98.0. 97.0. 96.0, 95.0, 94.0. 93.0. 92.0, 91.0. 
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90. 

0. 

89, 

.0. 

88, 

.0. 

87. 

.0. 

86, 

.0. 

85, 

.0. 

84, 

.0. 

83. 

.0. 

82 

.0. 

81 

.0. 

80. 

0. 

79, 

.0. 

78. 

.0. 

77. 

.0. 

76. 

.0. 

75 

.0. 

74. 

.0. 

73. 

.0. 

72, 

.0. 

71 

.0. 

70. 

0, 

69, 

.0, 

68. 

.0. 

67. 

.0. 

66, 

.0. 

65, 

.0. 

64. 

.0. 

63. 

.0. 

62 

.0. 

61 

.0. 

60. 

0. 

59, 

.0. 

58. 

.0. 

57. 

.0. 

56. 

.0. 

55, 

.0. 

54. 

.0. 

53. 

.0. 

52, 

.0. 

51 

.0. 

50. 

0. 

49, 

.0. 

48. 

.0, 

47. 

.0. 

46. 

.0. 

45 

.0. 

44. 

.0. 

43. 

0. 

42 

.0. 

41 

.0. 

40. 

0. 

39, 

.0. 

38. 

.0. 

37. 

.0. 

36. 

.0. 

35, 

.0. 

34. 

.0. 

33. 

.0. 

32, 

.0. 

31 

.0, 

30. 

0. 

29, 

.0. 

28. 

.0. 

27. 

.0. 

26. 

.0. 

25, 

.0. 

24. 

0. 

23. 

.0. 

22, 

.0. 

21 

.0. 

20. 

0. 

19, 

.0. 

18. 

.0, 

17. 

.0. 

16. 

.0. 

15, 

.0. 

14. 

.0, 

13. 

0. 

12. 

.0. 

11 

.0. 

10. 

0. 

9, 

.0, 

8. 

.0. 

7. 

.0. 

6. 

.0. 

5. 

.0. 

4. 

.0. 

3. 

0. 

2, 

.0. 

1 

.0. 

0. 

0) 

i 



















begin(* getArray *) 
top :* 100; 
numbers := worstCase; 
printArray(top); 
end; (* getArray *) 

procedure bubbIeSort(start,top: integer; var subArray: standardArray); 
var 

Index: integer; 
switched: boolean; 
begin (* bubblesort *) 
repeat 
begin 

switched :- false; 

for index :« start to top-1 

do 

begin 

if (subArray[index] > subArray[index+1]) 
then 
begin 

swap(subArray[index],subArray[index+1]); 
switched :■ true; 
end; 
end; 
end; 

until switched = false; 
end; 


procedure findMedian(start, top: integer; var subArray: standardArray); 
var 

middle : integer; 
sorted: standardArray; 
begin (*findMedian 

(start+top)div 2; 

‘start]; 
top]; 
middle]; 


middle 

sorted 

sorted 

sorted 


:■ subArray 
:■ subArray 
:■ subArray 

bubbIeSort(1,3,sorted); 
if sorted[2] ■ subArray[middIe] 
then 

swap(subAr ray[start],subArray[middIe]) 
e I se 

if sorted[2] ■ subArrayftop] 
then 

swap(subArray[start],subArray[top]); 

end; 


procedure sortSect ion(start,top:integer); 
var 

swapUp: boolean; 
s,e,m: integer; 
begin 

if top-start < 6 
then 

bubbIeSort(start,top,numbers) 
e I se 
beg i n 

findMedian(start,top,numbers); 
swapUp :■ true; 


s :■ start; 
e top; 
m :■ start; 
while e > 8 


( continued ) 
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beg I n 

if swapUp - true 
then 

beg in . 

while (numbers[e] >- numbers[m]) and (e > m) 
do 

e e -1; 

If « > n 


then 

begin 

swap(number8[e],numbers[mJ); 

m : * e ; 

end; 

swapUp :■ false; 
end 

e I se 

while (numbers[s] <« numbers[m]) and (s<m) 
do 

s :* 3+1; 

1 f s < m 
then 
begin 

swap(numbers[s],numbers[m]); 
m :* 8 
end; 

swapUp := true; 
end; 
end; 

SortSection(start,m-1); 

SortSection(m+1.top); 
end; 

end; (* sortsection *) 
begin 

getArray(last); 
sortSection(0,last); 
printArray(last); 
end. 


tankard.Ibr 
BINARY 

"The Literary Detective," Jim Tankard. 

February, page 231. Download lu.exe to unpack this library. 


OREM FREQUENCY ANALYZER 1 
20 REM 

30 REM BY JIM TANKARD 

40 REM 3003 CHERRY LANE 

50 REM AUSTIN, TEXAS 78703 

60 REM 

70 DIM AX(26),B%(26): REM THESE ARRAYS HOLD 
THE TWO FREQUENCY COUNTS TO BE COMPARED 
80 LET SI% « 0 
90 D$ = CHR$ (4) 

100 REM GETS NAMES OF FILES 
110 INPUT “WHAT FILE CONTAINS THE FIRST 
FREQUENCY COUNT?";N$ 

120 INPUT "WHAT FILE CONTAINS THE SECOND 
FREQUENCY COUNT?";M$ 

130 REM OPENS FIRST FILE AND READS ITS 
FREQUENCIES INTO AX(I) 

140 PRINT D$;"OPEN ";N$ 

150 PRINT D$;"READ ";N$ 

160 FOR I = 1 TO 26 

170 INPUT C$: LET C% = VAL (C$) 

180 LET A%( I) - C% 

190 NEXT I 

200 PRINT D$;"CLOSE ";N$ 

210 HOME 

220 REM OPENS SECOND FILE AND READS ITS 
FREQUENCIES INTO BX(I) 

230 PRINT D$;"OPEN “;M$ 
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240 PRINT D$;"READ ";M$ 

250 FOR I = 1 TO 26 

260 INPUT C$: LET C% = VAL (C$) 

270 LET B%(I) - C% 

280 NEXT I 

290 PRINT D$;"CLOSE ";M$ 

300 REM COMPUTES DIFFERENCE INDEX 
310 FOR I * 1 TO 26 

320 LET SIX « SIX + ABS (AX(I) - BX(I)) 
330 NEXT I 

340 REM PRINTS RESULTS 
350 HOME 

360 PRINT "FIRST SAMPLE: ";N$ 

370 PRINT 

380 PRINT "SECOND SAMPLE: ";M$ 

390 PRINT 

400 PRINT "DIFFERENCE INDEX: ";SIX 
410 END 


0REM FREQUENCY ANALYZER 2 
20 REM 

30 REM BY JIM TANKARD 

40 REM 3003 CHERRY LANE 

50 REM AUSTIN. TEXAS 78703 

60 REM 

70 DIM AX(26,26),B%(26,26): REM THESE ARRAYS 
HOLD THE TWO FREQUENCY COUNTS TO BE COMPARED 
80 LET SIX = 0 
90 D$ - CHR$ (4) 

100 REM GETS NAMES OF FILES 

110 INPUT "WHAT FILE CONTAINS THE FIRST 
FREQUENCY COUNT?";N$ 

120 INPUT "WHAT FILE CONTAINS THE SECOND 
FREQUENCY COUNT?";M$ 

130 REM OPENS FIRST FILE AND READS ITS 
FREQUENCIES INTO AX(I.J) 

140 PRINT D$;"OPEN ";N$ 

150 PRINT D$;"READ ";N$ 

160 FOR I = 1 TO 26 

170 FOR J = 1 TO 26 

180 INPUT C$: LET CX - VAL (C$) 

190 LET AX(I.J) - CX 

200 NEXT 

210 NEXT 

220 PRINT D$;"CLOSE ";N$ 

230 HOME 

240 REM OPENS SECOND FILE AND READS ITS 
FREQUENCIES INTO BX(I.J) 

250 PRINT D$;"OPEN ";M$ 

260 PRINT D$;"READ ";M$ 

270 FOR I - 1 TO 26 

280 FOR J = 1 TO 26 

290 INPUT C$: LET CX - VAL (C$) 

300 LET BX(I.J) = CX 

310 NEXT 

320 NEXT 

330 PRINT D$;"CLOSE M ;M$ 

340 REM COMPUTES DIFFERENCE INDEX 

350 FOR I - 1 TO 26 

360 FOR J - 1 TO 26 

370 LET SIX * SIX + ABS (AX(I.J) - BX(I,J)) 

380 NEXT 

390 NEXT 

400 REM PRINTS RESULTS 

410 HOME 

420 PRINT "FIRST SAMPLE: ";N$ 

430 PRINT 

440 PRINT "SECOND SAMPLE: ";M$ 

450 PRINT 

460 PRINT "DIFFERENCE INDEX: ";SIX 

470 END 
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10 

REM 

TEXT GOBBLER 1 

20 

REM 


30 

REM 

BY JIM TANKARD 

40 

REM 

3003 CHERRY LANE 

50 

REM 

AUSTIN. TEXAS 78703 

60 

REM 



70 OIM Z(100): REM STORES INITIAL 
FREQUENCIES OF LETTERS 
80 DIM ZX(100): REM STORES FREQUENCIES 

OF LETTERS AFTER NORMALIZING TO 1000 LETTERS 
90 DIM Z%(100): REM STORES FREQUENCIES OF 

LETTERS AS INTEGERS NORMALIZED TO 1000 LETTERS 
100 DIM Z$(100): REM STORES FREQUENCIES OF 
LETTERS IN STRINGS 
110 R$ = CHR$ (13) 

120 D$ = CHR$ (4) 

130 AS$ * CHR$ (42) 

140 TEXT : HOME 

150 PRINT « TEXT GOBBLER 1“ 

160 PRINT 

170 PRINT "THIS PROGRAM COUNTS THE SINGLE LETTER 
FREQUENCIES IN A SAMPLE OF PROSE TEXT." 

180 PRINT 

190 PRINT "IT WILL THEN PRINT OUT A TABLE OF 
THOSE FREQUENCIES ON YOUR PRINTER." 

200 PRINT 

210 PRINT "IT WILL ALSO STORE THE FREQUENCIES 
IN A FILE SO THEY CAN BE COMPARED WITH THE 
FREQUENCIES FROM ANOTHER SAMPLE BY MEANSOF 
’FREQUENCY ANALYZER 1’.“ 

220 PRINT 

230 INPUT "WHAT FILE CONTAINS THE TEXT YOU WANT 
TO ANALYZE? ";N$ 

240 PRINT D$;"OPEN “;N$ 

250 PRINT D$;"READ ";N$ 

260 FOR I - 1 TO 100 
270 LET ST = 0 
280 LET A$ = "" 

290 : GOSUB 1000 
300 PRINT A$ 

310 NEXT I 

320 PRINT D$;"CLOSE ";N$ 

330 PRINT CHR$ (7): REM RINGS BELL WHEN 
THROUGH READING TEXT 
340 GOSUB 5000 
350 TEXT : END 

1000 REM READS TEXT 240 CHARACTERS AT A TIME 
1010 GET C$: PRINT C$; 

1020 LET ST = ST + 1 
1030 IF C$ = R$ THEN RETURN 
1040 GOSUB 2000 
1050 A$ *> A$ + C$ 

1060 IF ST = 240 THEN RETURN 
1070 GOTO 1000 

2000 REM COUNTS FREQUENCIES OF CHARACTERS. 

SPACES AND LETTERS 
2010 LET XI = ASC (C$) 

2020 LET Cl = Cl + 1: REM COUNTS TOTAL 
NUMBER OF CHARACTERS 

2030 IF XI = 32 THEN LET B1 - B1 + 1: GOTO 

2080: REM COUNTS TOTAL NUMBER OF SPACES 

2040 IF XI > 96 AND XI < 123 THEN LET XI = XI - 
32: REM ELIMINATES LOWER CASE LETTERS 
2050 IF XI > 64 AND XI < 91 THEN LET CH = 

CH + 1: REM COUNTS TOTAL NUMBER OF LETTERS 
2060 LET Z(X1) = Z(X1) + 1: REM INCREMENTS 
ARRAY ELEMENT SERVING AS COUNTER 
2070 IF C$ = AS$ THEN GOTO 320: REM LOOKS 
FOR ASTERISK AT END OF TEXT 
2080 RETURN 

5000 REM NORMALIZES FREQUENCIES TO SAMPLE OF 
1000 AND GETS THEM READY TO STORE 
5010 FOR I = 65 TO 90 

5020 LET ZX(I) = (Z(I) / CH) * 1000: REM 
NORMALIZES TO SAMPLE OF 1000 
5030 LET Z%(I) = INT (ZX(I) + .5): REM 
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5040 

5050 

6000 

6010 

6020 

6030 

6040 

6050 

6060 

6070 

6080 

6090 

6100 


6110 

6120 

6130 

6140 

6150 

6160 

6170 

6180 

6190 

6200 

6210 

6220 

6230 

8000 

8010 

8020 

8030 

8040 

8050 

8060 

8070 

8080 

8090 

8100 

8110 

8120 

8130 

8140 

8150 

8160 

10000 

10010 

10020 

10030 

10040 

10050 

10060 

10070 


CHANGES FREQUENCY TO INTEGER VALUE 
LET Z$(I) = STR$ (Z%(I)): REM CHANGES 
INTEGER TO STRING 
NEXT I 

REM PRINTS MENU 
PRINT PRINT 

PRINT " PRESS ANY KEY TO CONTINUE. 1 ': 

GET Q$: PRINT Q$ 

HOME 

PRINT " WHICH DO YOU WANT TO DO?" 

PRINT 

PRINT " 1. PRINT THE LETTER FREQUENCY COUNT." 
PRINT 

PRINT " 2. STORE THE LETTER FREQUENCY COUNT 
IN A DISK FILE." 

PRINT 

PRINT " 3. RUN THIS PROGRAM AGAIN TO 

GET THE FREQUENCY COUNT FOR 
ANOTHER SAMPLE." 


RUN 'FREQUENCY ANALYZER 1 # ." 
EXIT THIS PROGRAM." 

CHOOSE 1, 2, 3. 4 OR 5." 


PRINT 
PRINT " 4 
PRINT 
PRINT " 5 
PRINT 
PRINT " 

GET Q$: PRINT 

IF Q$ * "1" THEN GOSUB 8000 

IF Q$ = "2" THEN GOSUB 10000 

IF Q$ = "3" THEN PRINT D$;"RUN TEXT GOBBLER 1" 

IF Q$ « "4" THEN PRINT D$;"RUN 

FREQUENCY ANALYZER 1" 

IF Q$ = "5" THEN END 
GOTO 6030 

REM PRINTS FREQUENCY RESULTS WITH PRINTER 
HOME 

PRINT "TURN ON YOUR PRINTER, THEN HIT 
ANY KEY.": GET Q$: PRINT Q$ 

PR# 1 

FILENAME 


NUMBER OF CHARACTERS 
NUMBER OF SPACES 
LETTER ACTUAL 

65 TO 90 

"; CHR$ (I),Z(I),Z%(I) 


PRINT " 

PRINT 
PRINT " 

PRINT 
PRINT " 

PRINT 
PRINT " 

PRINT 
FOR I = 

PRINT " 

NEXT I 
PR# 0 
RETURN 

REM STORES THE FREQUENCY MATRIX ON 

A DISK FILE 

HOME 

INPUT "WHAT NAME DO YOU WANT TO GIVE 
TO THE FILE?";N$ 

PRINT D$;"OPEN ";N$ 

PRINT D$;"WRITE ";N$ 

FOR I = 65 TO 90: PRINT Z$(I): NEXT I 
PRINT D$;"CLOSE" 

RETURN 


";N$ 

" ;C1 
" ;B1 

NORMALIZED" 


10 

REM 

TEXT GOBBLER 2 


20 

REM 



30 

REM 

BY JIM TANKARD 


40 

REM 

3003 CHERRY LANE 


50 

REM 

AUSTIN, TEXAS 78703 


60 

REM 



70 

LET 

W1 = 32 


80 

DIM 

Z(26.26): REM STORES INITIAL 


FREQUENCIES OF LETTERS 


90 

DIM ZX(26,26): REM STORES 

FREQUENCIES 


OF LETTERS AFTER NORMALIZING 

TO 10000 LETTERS 

100 

DIM Z%(26,26): REM STORES 

FREQUENCIES 


OF LETTERS AS INTEGERS NORMALIZED TO 10000 LETTERS 



February 


110 

120 


STORES FREQUENCIES OF 


170 

180 

190 

200 

210 

220 

230 


240 
250 

260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
1000 
1010 
1020 
1030 
1040 
1050 A$ 
1060 
1070 
2000 

2010 
2020 

2030 

2040 

2050 

2060 

2070 


2080 

2090 

2100 

2110 

2120 

5000 


DIM Z$(26,26): REM 

DIM T ZP$(26 26)* N REM STORES FREQUENCIES 

OF l1?teSsin'strings with spaces so tables 

WILL BE LINED UP 
130 R$ - CHR$ (13) 

140 D$ - CHR$ (4) 

150 AS$ - CHR$ (42) 

160 ;St : “ E TEXT GOBBLER 2" 

PRINT "THIS PROGRAM COUNTS THE LETTER „ 

PAIR FREQUENCIES IN A SAMPLE OF PROSE TEXT. 

PR T NT 

PRINT "IT WILL THEN PRINT OUT A TABLE 
OF THOSE FREQUENCIES ON YOUR PRINTER. 

PRINT “IT WILL ALSO STORE THE FREQUENCIES 
W A FILE SO THEY CAN BE COMPARED WITH 
THE FREQUENCIES FROM ANOTHER SAMPLE BY 
MEANSOF ’FREQUENCY ANALYZER 2.’" 

555 "WHAT FILE CONTAINS THE TEXT YOU WANT 
TO ANALYZE? ";N$ 

PRINT D$;"OPEN ";N$ 

PRINT D$;"READ ";N$ 

FOR I • 1 TO 100 
LET ST - 0 
LET A$ = "" 

: GOSUB 1000 
: PRINT A$ 

NEXT I 

PRINT D$;"CLOSE ";N$ 

GOSUB 5000 

T REM READS TEXT 240 CHARACTERS AT A TIME 
GET C$: PRINT C$; 

LET ST = ST + 1 
IF C$ = R$ THEN RETURN 
GOSUB 2000 
A$ + C$ 

IF ST = 240 THEN RETURN 

REM COUNTS FREQUENCIES OF CHARACTERS, 

SPACES AND LETTER PAIRS 

LET Cl = C1 S + I^REM COUNTS TOTAL 

rxf.V"? B1 - B1 ♦ 1: REM 
COUNTS TOTAL NUMBER OF SPACES 

Jl ELIMINATES^ LOWER dsE LETTERS 

g *V rem AND counts 9 total N LET nu C m H be = r of letters 

?? C$ » AS$ THEN GOTO 340: REM LOOKS 
FOR ASTERISK AT END OF TEXT _ 

IF XI < 65 OR XI > 90 THEN LET W1 - 32. 

GOTO 2120: REM IF CHARACTER IS NOT A 
LETTER. ASSIGNS 32 TO W1 
LET XI - XI - 64: REM CHANGES ASCII 

rsf-v™ wotur&M sk.ps 

“TO*,) *1 ■ A re£ TT “ncrements 

ARRAY ELEMENT SERVING AS LETTER PAIR COUNTER 
fp?Il= XI: REM STORES NUMBER FOR OLD 
LETTER IN W1 BEFORE GETTING NEXT CHARACTER 

rem UR normalizes frequencies and gets them 

READY TO STORE 


5010 

5020 

5030 

5040 


FOR I - 1 TO 26 

LET ZX(i!j)°- 2 (Z(I. j ) / CH ) * 10000: REM 

norm^IzesYo SAMPLE OF 10000 

LET Z%(I,J) = INT (ZX(I.J) + -5): REM 
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5050 

5060 

1 5070 
5080 

5090 

M „ + 

5100 

5110 

5120 

7000 

7010 

7020 

7030 

7040 

7050 

7060 

7070 

7080 

7090 

7100 


7110 

7120 

7130 

7140 

7150 

7160 

7170 

7180 

7190 

7200 

7210 

7220 

7230 

10000 

10010 

10020 

10030 

10040 

10050 

10060 

10070 

10080 

10090 

10100 

10110 

10120 

10130 

10140 

10150 

10160 

10170 

10180 

10190 

10200 

10210 

10220 

10230 

10240 

10250 

10260 

10270 


CHANGES FREQUENCY TO INTEGER VALUE 

LET Z$(I,J) = STR$ (Z%(I,J)): REM CHANGES 

INTEGER TO STRING 

REM ADDS SPACES TO STRINGS SO TABLE 

WILL BE LINED UP 

LET ZP$(I,J) = Z$(I,J) 

IF LEN (ZP$(I,J)) = 1 THEN LET ZP$(I,J) = 
" " + ZP$(I,J) 

IF LEN (ZP$(I,J)) * 2 THEN LET ZP$(I,J) = 
ZP$(I,J) 

NEXT 

NEXT 

PRINT CHR$ (7): REM RINGS BELL WHEN 
THROUGH READING TEXT 
REM PRINTS MENU 
PRINT : PRINT 

PRINT " PRESS ANY KEY TO CONTINUE.": 

GET Q$: PRINT Q$ 


HOME 
PRINT " 
PRINT 
PRINT " 

1 . 

WHICH DO YOU WANT TO DO?" 

PRINT THE LETTER FREQUENCY 

PRINT 
PRINT " 

2. 

COUNT." 

STORE THE LETTER FREQUENCY 

PRINT 
PRINT " 

3. 

COUNT IN A DISK FILE." 

RUN THIS PROGRAM AGAIN TO 

PRINT 
PRINT " 

4. 

GET THE FREQUENCY COUNT FOR 
ANOTHER SAMPLE." 

RUN ’FREQUENCY ANALYZER 2'. 

PRINT 
PRINT " 

5. 

EXIT THIS PROGRAM." 

PRINT 
PRINT " 
GET Q$: 

PRINT 

CHOOSE 1. 2, 3, 4 OR 5." 


IF Q$ = "1" THEN GOSUB 10000 

IF Q$ = "2" THEN GOSUB 13000 

IF Q$ = "3" THEN PRINT D$;"RUN 

TEXT GOBBLER 2" 

IF Q$ = "4" THEN PRINT D$;"RUN 
FREQUENCY ANALYZER 2" 

IF Q$ = "5" THEN END 
GOTO 7030 

REM PRINTS FREQUENCY RESULTS WITH PRINTER 
TEXT : HOME 

PRINT "TURN ON YOUR PRINTER, THEN HIT 
ANY KEY.": GET Q$: PRINT Q$ 

PR# 1 

PRINT CHR$ (9);"80N" 

PRINT CHR$ (27);"Q" 

HTAB 33: PRINT "FILENAME ";N$ 

PRINT 

HTAB 33: PRINT "NUMBER OF CHARACTERS ";C1 
PRINT 

HTAB 33: PRINT "NUMBER OF SPACES ";B1 
PRINT 

HTAB 21: PRINT "FIRST LETTER 
SECOND LETTER" 

PRINT 
HTAB 33 

FOR I = 1 TO 26 

PRINT " "; CHR$ (64 + I);" "; 

NEXT I 
PRINT 

FOR I - 1 TO 26 

PRINT " "; CHR$ (64+1);" "; 

FOR J - 1 TO 26 
PRINT ZP$(I,J);" "; 

NEXT 
NEXT 
PRINT 
PR# 0 
RETURN 


(continued) 
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13000 

REM STORES THE 
DISK FILE 

FREQUENCY MATRIX ON A 

13010 

HOME 


13020 

INPUT "WHAT NAME 

DO YOU WANT TO GIVE TO THE FIIE?";N$ 

13030 

PRINT D$;“OPEN " 

;N$ 

13040 

PRINT D$;"WRITE 

";N$ 

13050 

FOR I * 1 TO 26 


13060 

FOR J * 1 TO 26 


13070 

PRINT Z$(I,J) 


13080 

NEXT 


13090 

NEXT 


13100 

PRINT D$;"CLOSE" 


13110 

RETURN 


scanpoem.doc 

TEXT 



"Poetry Processing" by Michael Newman 

February, page 221. Also download scanpoem.exe and scanpoem.pas. 


I have provided a Pascal program (Editor’s note: The Microsoft 
Pascal source code and executable version are available from 
BYTEnet Listings, xxx-xxx-xxxx, as SCANPOEM.PAS and 
SCANPOEM.EXE. The executable version requires any MS-DOS or 
PC-DOS machine) that implements the syllabification algorithm 
and illustrates how the Poetry Processor "reads" a user’s poem 
according to a user-specified metric scheme. 

The present algorithm is not perfect, but it produces a 
readable, if not dictionary-perfect, syllabified word 95% of 
the time. To run the program, prepare two files. 

TEST.POE must contain the lines of poetry. You can write 
TEST.POE as a text file with each line of the poem on a 
separate line. A second text file, TEST.FRM, should have a line 
containing a string of dots (.) and dashes (-) Indicating the 
accentual scheme that each line of poetry is supposed to 
follow. Slashes indicating the end of a foot are optional. 

As an example, a Shakespearean sonnet (iambic pentameter) 

will have a TEST.FRM file consisting of 14 lines of 

Each line in TEST.FRM must end with an 
asterisk. After editing the TEST.FRM and TEST.POE files, you 
can run the program by entering its name, SCANPOEM. The 
computer will "read" the poem, printing in upper case the 
appropriately stressed syllables. 

Note that the program is a prototype version of the algorithm. 
It will not not handle text with capital letters, apostrophes, 
or punctuation, so be careful not to include them these 
features in TEST.POE. When using this demonstration program, 
you will undoubtedly find that some words are not properly 
syllabified. I leave it to the readers to improve upon the 
a Igorithm. 


0:2 


Textbox: Machine Reading Of Metric Verse 
by Paul Holzer 

A computer can definitively scan a line of poetry for its 
stress pattern principally in one of two ways: (1) an algorithm 
can deduce the syllabic structure and the stressed syllables 
from analysis of the letters that make up the word, or (2) the 
computer can look-up of every word in a dictionary database 
that holds the syllabification and accentuation of every word. 
The look-up method requires a large database, and the 
algorithmic approach is complex and requires a deep analysis of 
English phonetics and spelling. 

One of the features of a poetry processor is that the 
poet-user can specify the meter of every line of a poem. For 
example, the string represents iambic 
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pentameter. Dots indicate an unstressed syllable and 

dashes represent a stressed one. The slash "/" indicates 
the end of a foot, the basic metric unit. The opening line of 
Shakespeare's 18th Sonnet 

shall I comPARE thee TO a SUMmer’s DAY? 

is an example of a line of iambic pentameter with the stressed 
syllables are in upper case. 

After writing a poem, users might request a metric scan of 
the poem. I wiI I describe here a method for doing this which 
is not based on one of the two general solutions I mentioned in 
the first paragraph. Instead, the processor will break each 
word into its syllables and then redisplay each line, with each 
syllable in upper or lower case according to the position of 
the dots and dashes in a user-specified metric form. So, were 
Shakespeare trying to compose trochaic pentameter, with the 
metric pattern the processor would reply with 

SHALL i COMpare THEE to A sumMER’S day? 

He would read this to himself, trying to put the stress on 
the upper case syllables. Noting the rhythmic clumsiness, he 
might rewrite his line as follows: 

To a summer's day I shall compare thee 
and the processor would respond: 

TO a SUMmer’s DAY i SHALL comPARE thee. 

Sounds betterl 

The main task for the computer is to break each word into 
its syllables. The algorithm is based on a systematic 
application of what appear to be the general rules by which 

English words break into syllables. Of course, there are no 
fixed rules, as evidenced by the fact that different 
dictionaries give different syllabifications for the same word. 

The following is a simple version of the algorithm: 

1. Break the word up into a sequence of alternating vowel 
and consonant groupings. Thus MICROCOMPUTER becomes 

M I CR 0 C 0 MP U T E R. Wherever there is a vowel or 
group of contiguous vowels, there will be a syllable. 

We need only assign the neighboring consonants to the 
syllable on right or to the one on the left. 

2. If the first vowel-group has a consonant-group to its 
left, then assimilate this consonant-group to the 
vowel-group. This leads, in our example, to 

MI CR 0 C 0 MP U T E R. 

3. If the final vowel-group has a consonant-group to its 
right, then assimilate this consonant-group to the 
vowel-group. We now get MI CR 0 C 0 MP U T ER. 

4. For the remaining unassigned consonants, do the 

following: 

a) if the consonant stands alone, attach it to the 
following vowel. Thus we get MI CR 0 CO MP U 
TER. 


b) if there are two consonants, split them. We get 
MIC RO COM PU TER. 

c) if there are three consonants, then 

I) if there is a doubled consonant, then 
split the pair; thus APPLY -> A PPL Y -> 
AP PLY. 


(continued) 
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13000 

REM 


DISK 

13010 

HOME 

13020 

INPU1 

13030 

PRIN1 

13040 

PRIN^ 

13050 

FOR : 

13060 

FOR , 

13070 

PRIN‘ 

13080 

NEXT 

13090 

NEXT 

13100 

PRIN 

13110 

RETU 

scanpoem.de 

TEXT 


"Poetry Pr« 
February, | 


I have pro 
Pascal sou 
BYTEnet LI 
SCANPOEM.E 
PC-DOS mac 
and i I Iust 
according 

The pi 
readabIe, 
the time. 
TEST.POE i 
TEST.POE 
separate 
containin 
accentuaI 
follow. S 

As c 

wl I I has 

asterisk. 
can run i 
computer 
appropri« 

Not 

It will 
or punct 
features 
you wiI I 
syI Iabif 
a Igorith 


0:2 


flrst^f It dou bled consonant, but the 

«£.ri ^x'* b «.. «<• 

initial stryng 9 of h | , ettirs r i i n h orde? W to e take*- m t St preproc#ss the 
peculiarities of English orthographj? * k " t0 account certain 

os a'special ionsonant. ( ThJI Certo,n exceptions); treat it 
compute ~> c o mp u te -> co mp ute -> con, put.. 

2 ‘ two-letter sequences into 

"qu",°and "ck S con#onon *•• e.g.. 

3. Identify common suffixes For 

examp'e, the algorithm opplled to “blameless" would 

bl a m e I . ss -> bio me less. 

However, when " I ass" ? e . 

the in “blame" would h! d a8 .° 8uff,x - then 
yielding blame less r ® cogn,2dd as silent. 

4 ' r;;:;rr y ■. 

rather than " e nact". th enoct becomes “en act". 

set ct m rules b and7repro<!ess?ng 0 steps ° reasonob| y small 
syllabification of all worrti 9 ? t P to guarantee correct 
some of the inherent difficult!IsT ® XOmples wNI '"ustrote 

th. fragment -bitl- ?,"! "°' d "•"Ok.bit.- anl... 

ext.n* ive »rd p,J„ x »5J?5 

*■ ars^r.T:!:.!: *<*>••= >- 

would treat it correctly* t! 0 ^’ ?" d the al 9 0r ithm 
;‘! , ; i ^ d ‘i'f 8ep <T°te | y. y anJ th! clr.ict* pronounce 
modified to isolate “re^as’a Wer !. the al 9 0r ithm 
"react" correctly, but turn "reacl^inJo vU'JcJ" 0 * 

formulat! e a°ru!e U thot S |!ads a to S the the b ? St opproach is to 
requiring table look^s^r^JoruUo" !*** ° f C0S88 

Pascal soCrcf e code P a!d a ixecutoMe^ Edit?r ' S "° te: The M ’crosoft 
SCANPOEM L EXE! " 9 The X «ec^ tab I XX ’ 

PC-DOS machine) that imp I eme!ts*thl° n on >' M S-DOS or 

and illustrates how the Poetry P^!.!™) 0 " f '®°* ion ol 9crithm 

occording to a user-spec in.7met??c TcLJe * ° US6r ' S P ° em 

readable^tf e not°d?ctionary-p.rfect^svl i K,'* produces « 
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As an example, a Shakespearean sonnet (iambic pentameter) 
will have a TEST.FRM file consisting of 14 lines of 

Each line in TEST.FRM must end with an 
asterisk. After editing the TEST.FRM and TEST.POE files, you 
can run the program by entering its name, SCANPOEM. The 
computer will "read" the poem, printing in upper case the 
appropriately stressed syllables. 

Note that the program is a prototype version of the algorithm. 
It will not not handle text with capital letters, apostrophes, 
or punctuation, so be careful not to include them these 
features in TEST.POE. When using this demonstration program, 
you will undoubtedly find that some words are not properly 
syllabified. I leave it to the readers to improve upon the 
a Igorithm. 


About the Author: 

Paul Holzer (140 W. 16th St. Apt 3W New 
York, NY 10011) is a financial analyst and programmer for 
PaineWebber, Inc. He has a B.A. in Philosophy from Princeton 
University and an M.A. in Applied Mathematics from City 
University of New York. 


scanpoem.pas 

TEXT 

"Poetry Processing." See scanpoem.doc. 


program scanpoem(input.output); 
j Program written by Paul Holzer, Oct. 10, 1985 } 
const max I eng = 30; 
numsuf ■ 11; 
max I in = 80; 
maxver = 20; 
maxsyl = 20; 
maxchn ■ 20; 
maxfin ■ max Iin+maxsyI; 
tstsize = 2; 
left =0; right * 1; 


type 

charset « set of char; 
var 

copyright: string(36); 
in_fiIe: text; 

poem: arrayT1..maxver 1 of Istring(max 11n}; 

form: array[1..maxverJ of IstrIng(maxsyI); 

chain: array[1..maxchnl of string(maxI eng); 

finline: string(maxfin); 

f i lenom: string(12); 

tword: string(maxI eng); 

vowels, letters, xletters: charset; 

sibs, dentals: charset; 

brknwrd: string(maxI eng); 

i. j» k, n, pos, numver, numwrds: integer; 

fch, pch: char; 

stress: boolean; 

xgrid: array[0..12] of string(2); 
sufmat: arrayT1..numsuf] of string(4); 
inword: array[1..tstsize] of strlng(maxI eng); 
mids: charset; 

rassim: array[1..29] of charset; 
va I ue 

copyright :■ *(C) 1985 Michael Newman, Paul Holzer*; 
letters :« [* a *..*z*,*E*,* I*,*Y*]; 
xletters :■ [ *0’..*9* ,*:*,*;’,*<*]; 
vowels :■ [*a*,*e‘,*I*,*o*,*u',*y*]; 


(continued) 
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sibs [’x 1 ,’z’, 1 J*,’g’ 
dentals :■ ['d', 1 t 1 ]; 


* 8 * , * c *, 5 , 1 ]; 

’k *,'I*,’m’,'n*,*p* 


xgrid[0 3 
xgrid[4] 
xgrId[8] 
xgrId[12] :* ‘gn f ; 


*t*,*w’ 



'ck*; 

xgr id 

T 

:« ’ch* 

’gh*; 
:« * rh *; 

xgr id 

'3' 

’ph* 

xgr id 


’sh* 

' th'; 

xgr id 

’7' 

’wh* 

‘qu *; 
’si •; 

xgr id 

9 

:« *gu* 

xgr id 

[11] ’ti 


sufmat[11 := , **ly’; sufmat[2] := '***y’; 
sufmat[3] :* ’**er•; 

sufmat[ 4 ] :■ **agE'; sufmat[ 5 ] := **est'; 
sufmat[ 6 ] :** * *ing'; 

sufmat[7] :» ‘ness*; sufmat[8] ’less'; 
sufmat[9J :* **fuI *; 

sufmat[10] := *ment'; sufmat[11] :« ’tirnE’; 


rassim 

,1 

=« [■ 

’ r *, 

rassim 

[6 ] 

C 

1 r * , 

rassim 

12 

; s 

[]; 

rassim 

‘18’ 



rassim 

28 

; s 

•r* 

rassim 

23 


>• 


I* ] ; rass i m T 3 ] : s 

r # •n*]; rassim[10] 
rassim[13] :* [ 
*m',* I']; rassim[19 
*n’,*m',* I *]; rassim 
* I']; rassim[26] 


[ , r , »*r]; rassim[ 5 ] : = 

= [ * r *, * I’ ] ; rassim[11] 
; rassim[15] := [*r* ,' I* 
:■ [ • r * ]; rassim[22] 

29]:■['r']; rass»m[24J:= 

= L ' I ’. * r * J; 


[*r•, • I 
U; 

,*s*, 'n 
[ * r 
[ * I •, * r 


procedure swapch(vars x, y: char); 
var 2 : char; 
beg i n 

z ;■ x; x y; y z 
end; 


function min(x, y; Integer); integer; 
beg i n 
min :* x; 

if y < x then min :* y 
end; 


function lowcase(ch: char); char; 
j returns lower case form of a letter } 


begin 

lowcase := ch; 
if ord(ch) > 64 then 

lowcase := chr((ord(ch) mod 32) + 

end; 


96) 


function upcase(ch: char); char; 
j returns upper case form of a letter } 
begin 

upcase :* ch; 
if ord(ch) > 64 then 

upcase :* chr((ord(ch) mod 32) + 64) 

end; 

procedure strip(vars qword: string; var Ing: integer); . 

{ strips leading blanks and returns length of a string of letters * 

var i: integer; 

tword: string(maxI eng); 


begin { strip \ 

for i := 1 to maxleng do tword[i] :* 
i ;= 0; Ing 0; 

repeat i := i + 1 until tword[i] in 
repeat 

Ing := I ng + 1; 
qword[lngj :« tword[i]; 
i ;« I + 1; 

until not (tword[i] in letters); 
end { strip 


qwo r d[i]; 
Ietters; 


procedure siI Iify(consts qword: string; vars bword: string); 

{ the main procedure for syllabifying a word, and described in detai 
in comments below. In general, it works by initially putting the al¬ 
ternating sequences of consonant and vowel groups of a word into the 
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matrix fiber, then attaching the consonants to the vowels, where the 
syllables are, according to certain rules } 

var i,j,pos: integer; 

fiber; array[ 1 .. 20 ] of string( 6 ); 

Iastcons, chng, plural, issuf: boolean; 

isplur, ispast, isswap: boolean; 

ch, ch 2 : char; 

frag, suffix: string(4); 

last, lastodd, Ing: integer; 

tword; string(maxI eng); 

x, m, y: char; 

spI it: integer; 

function iscons(ch: char): boolean; 

{ returns true if ch is a consonant, false otherwise * 
begin 

if ch in vowels then iscons := false else iscons :** true 

end; 


function cmotch(inch: char; patch: char): boolean; 

j returns true if inch = patch or if patch = false otherwise 5 

beg i n 

cmatch := false; 

if patch = then cmatch :* true 
e I se 

if inch = patch then cmatch :« true 

end; 

function fndsuf(consts frag: string; vars suffix: string): boolean; 
j returns true if the string frag matches one of the suffixes in sufmat, 
and returns the suffix in suffix \ 
var i,j,k: integer; 
fnd: boolean; 


begin \ fndsuf } 

for i :« 1 to 4 do suffix[i] 


i := 0 ; 

repeat i :* i + 1 ; 
fnd := true; 
for j :■ 1 to 4 do 

if not cmatch(frag[j], sufmat[i,ij) 
else for k :» 1 to 4 do suffix[k] : 
untiI fnd or (i s numsuf); 
fndsuf :■ fnd 
end { fndsuf }; 


then fnd 
sufmat[ 


:= false 

.k] 


function tr(m: char): integer [PURE]; 
begin 

if m in xIetters then tr :*■ ord(m) - 25 
else tr :* ord(m) - 97 

end; 


procedure initfib; Ai .. 

{ cnverts final ’e’ of tword to the "consonant" *E’ , then sorts the alter¬ 
nating consonant/vowel groups into the rows of the 20 x 6 character matrix 
fiber. The last row containing a letter is returned in last \ 
var i,j,pos: integer; 


ch: char; 

lastcons: boolean; 


begin { initfib \ 
if tword[lng] ■ *e' then 

if iscons(tword[Ing- 1 ]) then begin 
tword[lng] *E'; 

If isplur then begin 

if tword[Ing- 1 ] in sibs then tword[lng] := ’e' 
end else 

if ispast then begin 

if tword[Ing- 1 ] in dentals then tword[lng] :« ’e’ 

end 

end; 

for i :« 1 to 20 do 
for j :■ 1 to 6 do 


[continued) 
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fIber[I.J] * * 


the syllable separator symbol "/" Is Initially placed between all groups 


for i :■ 2 to 20 do fiber[l, 6 ] :■ '/*• 

|.«MS=s = sa.«Bs aa r: = sBM«an B Bsa S saa««»a a = s B s a * a ss*«SBs = a a BS =sss» = = ! 

blanks are Ignored. Consonant groups are placed In odd-numbered 
rows, vowel groups In even-numbered ones. ^ 

| :■ 1 ; J :■ 1; pos :« 1 ; lastcons :« true; 
ch :■ tword[pos]; 
while pos <« Ing do 

If ch * * * then begin 
pos :» pos + 1 ; 
ch := tword[pos]; 
end 

e I se beg In 

if lastcons « iscons(ch) then begin 
fiber[I,J] : = ch; 

j J + 1 

end 

else begin 

i i + 1; j 1; 

fiber[i,j] := ch; 

j j + i; 

lastcons := not lastcons 

end; 

pos :*= pos + 1 ; 
ch := tword[pos] 

end; 

Iast :* i ; 
end j initflb }; 


beg in { siI Iify \ 

issuf := false; isplur :« false; ispast := false; 
isswap :■ false; 

for i ;= 1 to maxleng do tword[i] ;= qwordfi]; 
strip(tword, Ing); 

if (tword[Ing] - ’s’) and (tword[Ing- 1 ] <> 's') then begin 
Ing := Ing - 1; 
isplur := true 
end else 

if Ing > 4 then 

if (tword[Ing] = ’d’) and (tword[lng - 1 ] = 'e’) then beg 
Ing :* Ing- 1 ; 
ispast ;* true 


in 


end; 

if Ing > 3 then 

if tword[lng] » ’e’ then _ _ . x 

if (twordflng- 1 ] in [ • I * . * r ’ ] ) and not (tword[Ing- 2 J in vowels) 
then begin 

swapch(tword[Ing], tword[lng- 1 ]); 
isswap :** true 


end; 

^tword is now scanned from right to left, and the following letter 
conversions are made in the following case statement: 


'gn* is converted to the xletter *<’; 

*gu* followed by a vowel is converted to *9*; 

*qu’ is converted to * 8 *; 

* ch', *gh*, * ph', * rh', *sh*, 'th*, and 'wh* are converted to 
*1, *2*, *3* , *4’, ’ 5 \ ’ 6 \ *7*, respectively; 

*ck’ is converted to * 0 ’; 

*i• followed by a vowel is converted to the "consonant" * 1 ', 
but ’si* and *tl* are further converted to and ; 
*y* followed by a vowel is converted to "consonant" 'Y*. 


for i Ing downto 2 do begin 
ch := twordfi]; 
case ch of 

*n': if twordfi- 1 ] = *g* then begin 
twordfi- 1 ] :* *<*; 
twordfi] := * '; 

end; 

•u*: if (twordfi- 1 ] = ’g*) and (tword[i+ 1 ] in vowels) then begin 
tword[i-l] :* *9*; 
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•h’ 


tword[i] :* * '; 
end 

C S6 if tword[i- 1 ] = *q* then begin 
tword[i- 1 ] := * 8 ' ; 
tword[i] :* * *; 

end; 
beg i n 

chng :* true; 
ch 2 :* tword[i-l]; 
case ch 2 of 


’k’ 


* c *: tword 

i- 1 * 

:* * 1 '; 

’g*: tword 

i-i 

:= *2*; 

* p*: tword 

i-i 

*3*; 

* r’: tword 

'i-i 

:* *4*; 

•s*: tword 

‘i-i 5 

:* ’5'; 

* t': tword 

[i-i 

:= ’ 6 ’; 

*w*: tword 

i-i' 

:= *7*; 

otherwise chng 

:* false 

end; 



if chng then 

tword[iJ :* * 

end; 



if tword[i- 1 ] 

= * < 

c* then fc 

tword[i- 1 ] : = 

* 0 *; 

tword[i] 

. _ » 

• 

end; 



begin 



if tword[i+l] 

i n 

vowels ti 

tword[i 1 

:*= ' 

1*5 

if tword[i- 1 J 

= ’s’ tl 

tword 

l[ i -1 J :*= 

tword 

i[i] 

, i » 

end 



e 1 se 




end 


'if tword[i- 1 ] = *t* then begin 
twordTi- 1 ] :■ *;*; 
tword[i] :* ' 


end 
end; 


if tword[i+l] in vowels then tword[i] :* *Y'; 


V 

otherwise 

end; 

end; 

pos 0 ; 

for i := 1 to Ing do 

if tword[i] <> * * then begin 
pos := pos + 1 ; 
tword[pos] :* twordfij 
end 

else Ing :«= Ing - 1 ; 

^initialize syllabification by calling initfib 


initfib; 


* = 7 === 7 !Th^c - nt Tetters, get the lost four ond test whether they 

HrH suf ix by coiltni fndsuf. 9 If o suffix is found, then remove it 
Ind repeot the process. by_co II ing_init ^'b = with = the = word = m ,nus = , ts = suff , x. 

if last > 4 then begin 

for i :« 1 to 4 do frog[i] tword[Ing-4 +1 ]; 

if fndsuf(frog, suffix) then begin 
for i ;■ 1 to 4 do 

If suff!x[i] <> •*' then Ing Ing - 1; 
issuf :■ true; 

Initfib 

end; 

end; 

fiber[Iast, 6 ] 
if odd(last) then begin 
fiber[last- 1 , 6 ] :• * 
lastodd :* last - 2 ; 
end 

e I se begin 


(continued) 
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lostodd :■ last - 1 


end; 


We now inspect all consonant groups starting with the first to follow a vowel 
(row 3 of fiber) and ending with the last group to precede a vowel (row 
lastodd). We associate the consonant in each group with the preceding or 
following vowel groups according to rules described in comments below. In 
these comments, upper case letters stand for arbitrary consonants. 


i 3; 

while i <■ lastodd do begin 
if 


f i ber[i,2] - • • then 
if fiber [1,1] <> *x' then 


e I se 


fiber[I,6] :« * * 
else fiber[i-1,6] :« 


j exactly 1 consonant \ 
I /C/ »> /C } 


if fiber[i,3] 


e I se 


f iber 
fiber 
f i ber 
f i ber 
end 


1 , 6 ] := 
1 - 1 . 6 ] 
i 
i 


then begin 


\ exactly 2 consonants } 
j /CD/ -> C/D J 


, 3] :■ fib 
. 2 ] := •/• 


f i ber[i, 2]; 


if fiber[l,4] ■ * ' then begin { exactly 3 consonants \ 

" f1.3]; 


x fiber[f,1]; m :« fiber[l,2]; y fiber 
split := right; 
if y ■ m then split :■ left 
e I se 

if m In mids then 

if y in rassIm[tr(m)] then split left; 
case split of 

a i n 

{ /CDE/ «> CD/E { 


| /CDE/ -> C/DE \ 


end; 

otherwise 

end; 

end 

else begin 


beg i n 
f i ber 

[i-i. 

6 ] := * *; 

f i ber 

1.6 

; b • • • 

f i ber 

!'- 4 ' 

fiber[1.3] 

fiber 

[1.3] 

•/* 

end; 
beg i n 
f iber 

; i-i . 

6 ] 1 *: 

fiber 

,1.6] 

:■ ’ '; 

fiber 

,i .4, 

:■ f iber[i,3] 

fiber 


:■ fiber[1,2} 

f I ber 

[1.2] 

V 


end; 
i := i + 2; 
end; 


i 4 or 5 consonants } 


f i ber 

[1-1. 

6 ] • •: 

f i ber 

i. 6] := * •; 

f i ber 

i.5] 

:* fiber[I,4]; 

f i ber 


:= f iber[ i ,3]; 

fiber 

[1.3] 

V 


Put the syllabified word back together, ignoring spaces in fiber and 
converting special consonants back to normal spelling. 


for i := 1 to maxleng do bwordfi] 
pos :« 0; 

for i := 1 to last do 

for j :« 1 to 6 do begin 
ch := fiber[ i, j] ; 

if ch in (letters + [V*]) then begin 
pos :« pos + 1; 
bword[pos] ;= lowcase(ch) 
end 

e I se 

if ch in xletters then begin 
pos := pos + 1; 

bword[pos] := xgrid[ord(ch)-48,1]; 
pos := pos + 1; 

bword[pos] := xgrid[ord(ch)-48,2]; 

end; 
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end; 

Reattach the suffix, if any, as final syllable. 


* 


if isswap then 

if bword[pos] * '/* then swapch(bword[pos-2],bword[pos-1]) 
e I se 

swapch(bword[pos], bword[pos-1]); 
if issuf then begin 
pos := pos + 1; 
bword[pos] :* */*; 
for i := 1 to 4 do 

if suffix[i] <> then begin 
pos := pos + 1; 
bword[pos] := suffix[i] 

end; 


end; 

if isplur then begin 
pos := pos + 1; 
bword[pos] :* ’s’ 

end; 

if ispast then begin 
pos :» pos + 1; 
bword[pos] := 'd* 

end; 

end j siI Iify }; 


procedure break In(consts tline: string; var numwrds: integer); 

{ breaks a line of poetry into a matrix of words, so that chain[i,j] 
is the j-th letter of the i-th word } 


var I, J, pos; integer; 
beg I n 

for i :■ 1 to maxchn do 

for j ;* 1 to maxleng do 
chain[i,j] * ’; 

pos :■ 0 ; i :* 0 ; 
while pos < maxi in do begin 
repeat 

pos :* pos + 1 

until (pos « maxlin) or (tIine[pos] in letters); 
if pos < maxlin then begin 
i i + 1 ; j 1 ; 
repeat 

chain[i, j] :* tline[pos]; 

J :■ j + 1 ; pos :■ pos + 1 
until (pos * maxlin) or not(tIine[pos] in letters) 

end 

end; 

numwrds :■ i; 
end; 


procedure pstress(ch: char; stress: boolean); 

{ converts a letter of upper case if parameter stress is true \ 
begin 

if ch in letters then 

if stress then write(upcase(ch)) 
else write(lowcase(ch)) 

e I se 

write(ch) 

end; 


begin { scanpoem j 
wr iteIn; 

{ read in the poem } 

assign(in_fiIe, 'test.poe*); 

reset(in_fI Ie); i :■ 0; 

while (not EOF(In_fiIe)) and (1 < maxver) do begin 

I :■ I + 1; 

read In( ln_f iIe, poem[i]) 

end; 

close(in_fiIe); numver :» i; 
j read In the form } 
assign(in_f1 Ie, ’test.frm’); 
reset(In_f1le); i :* 0; 


( continued ) 
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while (not EOF(in_fiIe)) and (I < maxver) do begin 

! I + 1; 

read In(in_fiIe, form[i]) 

end; 

c lose(in_fiIe); 

if i < numver then numver :■ I; 

j---—----- 

Each line read will be processed in sequence, by calling breakln on the 
line, calling sillify on each word of the line, and reconstructing the 
finished line in finline. finline is then displayed with syllables in 
upper case according to the pattern of dots and dashes in form. 

for i :« 1 to numver do begin 

for j 1 to maxfin do finline[j] :* • •; 
break In(poem[i],numwrds); 
pos := 0 ; 

for j ;* 1 to numwrds do begin 
siI I Ify(chaln[j], brknwrd); 
k 0 ; 
repeat 

k := k + 1; 
pos :■ pos + 1; 
finline[posl :■ brknwrd[k] 
untiI brknwrd[kJ « ' * 

end; 

pos :■ min(pos, maxfin- 1 ); 
finline[pos] := • •; f\nI Ine[pos +11 :■ •*•; 
j :« 1 ; pos :■ 0 ; fch :« form[i, jj; 
while fch <> '** do begin 

If fch <> •/• then begin 

if fch * then stress true 
else stress :« false; 
repeat 

pos := pos + 1 ; pch :* fin Iine[pos]; 
pstress(pch, stress) 
untiI pch in [* •*•/•] 

end; 

j :■ j + 1 ; fch :■ form[i, J] 

end; 

pos :■ pos + 1 ; 

while not (fin Iinefposl * ’*') do begin 
wr ite(fin Iinefpos]); pos :■ pos + 1 

end; 
wr i teIn 

end; 

end. 


readsim3.me 
TEXT 

"A SIMPL Compiler, Part 3: Extensions." See simpl3.bix. 


0uide to Part 3 of "A SIMPL Compiler." The 
file includes Modula-2 source code for the 
entire SIMPL Compiler. You will need the 
Monitor program from "Building a Computer 
in Sodtware (October ’85) and the VM2 Assembler 
(November ’85). There are thirteen modules 
to this final version of the compiler. 

CodeGen 
CodeWrite 

Compiler (MOD file only) 

ExprParser 
Ini t 
LexAn 
Node 
Parser 
Routines 
SymboI 
SymboI Tab I e 
Token 

TypeChecker 
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The programs were developed using MacModula-2, 
but conversion to other Modula-2 systems 
should be straightforward. I would appreciate 
hearing about any conversion dificulties or 
bugs. You can reach me on BIX as "jba" or by 
U.S. mail at 1643 Cambridge St. #34, Cambridge, 
MA 02138. Happy Compiling! 

Jonathan Amsterdam 

[Editor’s note: Because of the 8 character 
filename limit of MS-DOS, the above modules 
have been combined into one file. You whould 
break them into separate files before 
attempting to compile them.] 


natIang.Ibr 
BINARY 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. Download lu.exe to unpack. 


readnat.me 
TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


This disk contains a very compact "least common denominator" 
activation network editor and simulator written in xlisp. 

The program supports a maximum of 23 nodes in XLISP. 

two versions are provided; one for xllspl.2 and another 
for the more modern xlispl.4. 

There are a few sample networks included. Clock is 
a 3 node timing "circuit", and PARSE is a network 
of syntax for "John ate up the street" where the 
minimal attachment parse is chosen. 

these *.net files are saved and can be loaded by the program 
using the "F L file" command. NOTE: THE PARSE.NET 
FILE TAKES APPROX. 5 MINUTES TO LOAD ON AN IBM PC. 

♦.pit files are created with the File Plot option 
they are time versus activation level graphs which 
can be printed on any printer. If you use the plot 
function without resetting activation values to 0, 
the plot cycles will begin with the current activation 
values. A *?* on the printout means that two or more 
nodes have the same value. The ? substitutes for an 
overstrike. 

sa.Isp is the program for version 1.4. To load it, 
run xlisp, and then call (load "sa" t t) and then 
call (editnet) 

sa12.lsp Is a modified version for xlisp 1.2 
using nlambda functions instead of macros, hand- 
expanded backquotes, and several interation and 
predicate functions (from version 1.4) explicitly 
defIned. 

To run It, run xlisp 1.2, call (load "sa12") and then 
cal I (editnet) 


YOU MUST HAVE "devlce-ansi.sys" In your CONFIG.SYS FILE 
IN ORDER FOR THE CURSOR CONTROL FUNCTIONS TO WORK PROPERLY. 


[continued) 
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cIocknet 
TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


m a foo 
m s foo 15 
m a bar 
m s bar 49 
m a zot 
m I a foo bar 


m I i foo zot 

m I I bar foo 

m I a bar zot 

m I a zot foo 

m I I zot bar 


clockpIt 
TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


bar ■ B 
foo - A 

0.0 0.5 1.0 



+ 1- 




0 

T 1 


A 

B 

1 

- 


A 

B 

2 

- 


A 

B 

3 

- 

A 


B 

4 

- 

A 


B 

5 

- 

A 


B 

6 

- 

A 


B 

7 

- 

A 


B 

8 

- 

A 


B 

9 

- 

A 

B 


10 

- 

A 

B 


11 

- 

A 

B 


12 

- 

A 

B 


13 

- 

A 

B 


14 

- 

A 

B 


15 

- 

A 

B 


16 

- 

A 

B 


17 

- 

A 

B 


18 

- 

A 

B 


19 

- 

1 

► 


20 

- 

B 

A 


21 

- 

B 

A 


22 

- 

B 

A 


23 

- 

B 

A 


24 

- 

B 

A 



foo.net 

TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


m a foo 
m s foo 50 
m a bar 


m I a foo bar 
m I i bar foo 
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f oo .pit 
TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


bar * B 
foo * A 
0.0 

+ 1 - 

0 -B 

1 - B 

2 - B 

3 - 

4 - 

5 - 

6 - 

7 - 

8 - 

9 - A 

10 - A 

11 - A 

123— AA 

14 - A 

15 - A 

16 - A 

17 - A 

18 - A 

19 - A 


B 


A 


A 


B A 

AB 

A B 


0.5 


A 

A 


A 

A 


B 

B 

B 


B 


B 

BB 

B 

B 

B 

B 

B 

B 


1.0 


parse.net 
TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


m 

a 

John 

m 

s 

John 25 

m 

a 

npl 

m 

a 

ate 

m 

a 

V 

m 

a 

up 

m 

a 

adv 

m 

a 

prep 

m 

a 

the 

m 

a 

street 

m 

a 

np2 

m 

a 

vpl 

m 

a 

PP 

m 

a 

vp2 

m 

a 

s2 

m 

a 

si 

m 


a John npl 

m 


a John ate 

m 


a npl John 

m 


a npl s2 

m 


a npl si 

m 


a ate v 

m 


a ate up 

m 


a v ate 

m 


a v vpl 

m 


a v vp2 

m 


a up adv 

m 


a up prep 

m 


a up the 

m 


a adv up 

m 


i adv prep 


m 

1 

a 

adv vpl 

m 

1 

a 

prep up 

m 

1 

i 

prep adv 

m 

1 

a 

prep pp 

m 

1 

a 

the street 

m 

1 

a 

the np2 

m 

1 

a 

street np2 

m 

1 

a 

np2 the 

m 

1 

a 

np2 street 

m 

1 

a 

np2 vpl 

m 

1 

a 

np2 pp 

m 

1 

a 

vpl V 

m 

1 

a 

vpl adv 

m 

1 

a 

vpl np2 

m 

1 

i 

vpl pp 

m 

1 

1 

vpl vp2 

m 

1 

a 

vpl si 

m 

1 

a 

PP prep 

m 

1 

a 

PP np2 

m 

1 

i 

PP vpl 

m 

1 

a 

PP vp2 

m 

1 

a 

vp2 v 

m 

1 

l 

vp2 vpl 

m 

1 

a 

vp2 pp 

m 

1 

a 

vp2 s2 

m 

1 

a 

s2 npl 

m 

1 

a 

s2 vp2 

m 

1 

1 

s2 si 

m 

1 

a 

si npl 

m 

1 

a 

si vpl 

m 

1 

i 

si s2 
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porse.plt 
TEXT 


"InterpretotIon of Natural 
February, page 189. 


Language," Jordan Pollock and David L. Walt 



prep - G 
vpl - K 
vp2 - M 

si - 0 

s2 - N 


0.0 

+ |- 

0 -? 

1 -? 

2 -? 

3 -? 

4 -?? 

5 -?? 

6 -? ? 

7 -? ? 

8 -?? ? 

9 - ?MK ? 

10 - G ? K ? 

11 - G MF K? 

12 - G M F N? 

13 - G M N ? 

14 - G M N 

15 - G M N 

16 - G M N 

17 - G M N 

18 - G M N 

19- G lil N 

20 - GM N 

21 - G M N 

22 - GM N 

23 - GM N 

24 - ? N 



0.5 


K 

F K 
0 F 

0 


K 

F 

0 


1.0 


K 

F K 

0 F « 

0 F K 
0 F K 
0 F K 
0 F K 
OFK 


so.Isp 
TEXT 


"Interpretation of Natural 
February, page 189. 


Language," Jordan Pollock and David L. 


Waltz. 


(expand 45) ; make some space 

: r:dt:::rtr:r* ,, '*-*****r************************* 

. * editnet is the main routine 


(defun editnet () 

(prog (net node It) 

(setq net (-> Net new)) 

(CLS ) 

JurEi/^.i. \ force 9 C to ovoid xI isp bug 
(MENU (Quit File Modify Execute Showlinks) 

(q (return)) ’ 

(f (MENU (Load Save Clear Plot) 

(I (PUSH $FILES (openi (FNAME ".net")))) 
(s («=> net SAVE)) ;;;; 

(c (=> net CLEAR)) 

(p (=> net PLOT (=> net SUBNET) 

Cm fUFWii (laa ( PR 2 M ! T " how man >' c y c, es"))))) 

(m (MENU (Add-node Set-value Link Del -node Unlink) 
(a (setq node (PROMPT "name")) 

(=> net ADD («> Node new node))) 

(setq node («> net FIND “node")) 

(*> node ERASE) ' 

(-> node SETVALUE (PROMPT "value")) 

(-> node DRAW)) ;; 

(setq It (or (MENU 

(A—> I—o S<—> Xo-o Co->) 


(s 


(I 
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(»> (-> net FIND "from") LINKTO 
(-> net FIND "to") It)) 

(d (-> net DEL (-> net FIND "name"))) 

(u (=> (=> net FIND "from") UNLINK 

(-> net FIND "to"))))) 

(e (MENU (Reset Cycle) 

(r (=> net RESET)) 

(c (-> net RUN 

(PROMPT "how many cycles") 
t nlI nil)))) 

(s (-> net SHOWLINKS (-> net FIND "node")))) 

(go loop))) 

(defmacro MENU (Items irest actions &aux command expr) 
(setq command (FIRST-CHAR (PROMPT items))) 

(do11st (a actions expr) 

(and (= (FIRST-CHAR (car a)) command} 

(setq expr (cons 'progn (cdr a)))))) 


(defun FIRST-CHAR (x) ; first case I ess char 

(bit-and 31 (ascii (symbol-name x)))) 


(d 


efun PROMPT (str) ; read an atom 

(cond ($FILES 

(or (read (car $FILES)) 

(progn (close (car $FILES)) 

(setq $FILES (cdr $FILES)) 
(PROMPT str)))) 


(t (GOTO 1 1) 
(ERASETOEOL) 
(princ str) 
(princ “?“) 
(read)))) 


; I*************************************************** 

; * support functions 

; it************************************************** 


(defun PLABEL (a b c char fp) ; used by PLOT 
(princ a fp) 

(dotlmes (J (- (/ $PW 2) 3)) (princ char fp)) 
(princ b fp) .. 

(dot imes (j (- (/ $PW 2) 3)) (princ char fp)) 
(princ c fp) 

(terpri fp)) 


(defun PRINTL (I fp) S print 

(dolist (x I) (princ x fp) (princ " 
(terpri fp)) 


Iist w/o paren 
" fp)) 


(defun FNAME (typ) ; make a filename str 

(strcat (symbol-name (PROMPT "file")) typ)) 


(defmacro PUSH (stack item) ; standard macro 

‘(setq .stack (cons .item .stack))) 

(defun PSCALE (vol) ; (0.100)-->(0,$PW-1) 

(/ (* $PW val) $RES)) 


♦ Globa I varlab Ies 

*********♦*♦*♦*♦♦***♦*******♦♦*****♦**********♦)(***** 


(setq $RES 100) 
(setq $PW 60) 
(setq $ALV 20) 
(setq $ILV -45) 
(setq $FILES nil) 


resolution of arlth. 
printing width 
activation link value 
Inhibition link value 
stack of Input files 










February 


it************************************************** 

* primitives for handling screen updates 

* below Is for ANSI standard; need to personalize 

t*************************************************** 


(defun GOTO (I In col) 
(princ "NeT") 
(princ I In) 
(write-char 59) 
(princ col) 

(princ *H)) 


(defun CLS () 

(princ "\e[2J")) 


(defun ERASETOEOL () 
(princ "\e[0K")) 


; move the cursor 


; clear the screen 


; ERASE to end of line 


**************************************************** 
* macros for nonquoted object handling 
**************************************************** 


(defmacro defclass • define a new class 

(newclass superclass &rest Ivors) 

'(progn (setq .newclass (Class ’new)) 

(.newclass ’isnew .superclass) 

(.newclass ’Ivors ’.©ivars) 

’(.superclass .newclass))) 


(defmacro defmethod ; define a new method 

(class selector args &rest body) 

‘(progn (.class 'answer '.selector ’.args ’.body) 
’(.class .selector))) 


(defmacro «> (class selector &rest args) -.SEND message 
’(.class ’.selector .©args)) 

; **************************************************** 
; * The Net object 

. **************************************************** 


(defclass Net Object 

(nodes ; just a I 1st of nodes 

line)) ; and the next display line 

(defmethod Net Isnew () 

(setq line 2) 
self) 


**************************************************** 
* query methods 

**************************************************** 


(defmethod Net SUBNET (&oux I n) ; get a subnetwork 
(setq n (PROMPT "how many nodes")) 

(dotimes (i n (reverse I)) 

(PUSH I («> self FIND "node")))) 


(defmethod Net FIND (str) ; get o node by name 

(prog (out name) 

(setq name (PROMPT str)) 
look (doIist (n nodes) 

(and (eq (=> n NAME?) name) 

(setq out n))) 

(and out (return out)) 

(setq nome (PROMPT "the name of a node")) 

(go look))) 


; **************************************************** 
; * method which modify networks 

; **************************************************** 

(defmethod Net ADD (node) ; add a node 

(setq nodes (nconc nodes (cons node nil))) 

(«> node RENUM line) 

(setq line (1+ Iine)) 
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(-> node DRAW)) 

(defmethod Net DEL (node) ; delete a node 

(dolist (n nodes) (*> n UNLINK node)) 

(setq nodes (delete node nodes)) 

(«> self RENUMBER)) 

(defmethod Net CLEAR () ; empty network 

(do list (n nodes) («> n CLEARLINKS)) 

(setq line 2) 

(setq nodes nil) 

(«> self REDRAW)) 

(defmethod Net RESET () ; reset all nodes 

(dolist (n nodes) (=> n RESET)) 

(«> self REDRAW)) 

(defmethod Net RENUMBER () ; compact display 

(setq line 2) 

(dolist (n nodes) 

(=> n RENUM line) 

(setq line (1+ I ine))) 

(=> self REDRAW)) 


; **************************************************** 
; * methods for displaying, plotting, and saving nets 

; **************************************************** 


(defmethod Net REDRAW () ; REDRAW the screen 

[dolist (n nodes) (=> n DRAW))) 

(defmethod Net SHOWLINKS (node) ; graph 1 node 
[dolist (n nodes) (*> n SHOWTO node))) 


; RUN iterates n cycles and animates and/or plots 
(defmethod Net RUN (n aflag pflag fp &aux piine) 

(-> self REDRAW) 

(and pflag (dotlmes (i $PW) (PUSH piine n •'))) 
(dotimes (i n) 

(cond 

(pflag 

(princ (substr (strcat (itoa i) " ") 1 3) 

, f P) . 

(princ fp) 

(mapl #'(lambda (x) (rplaca x " ")) piine) 
(dolist (n nlist) (*> n PLOT pline)) 

(dolist (ch pline) (princ ch fp)) 

(terpr I fp))) 

(dolist (n nodes) (■> n SEND)) 

i dolist (n nodes) (*> n UPDATE aflag)) 

GOTO 1 1) 
princ 1) 
terprt))) 


; SAVE creates a file with commands to recreate net 
(defmethod Net SAVE (&aux fp) 

(setq fp (openo (FNAME M .net M ))) 

(dolist (n nodes) («> n DUMP fp)) 

(doIist (nl nodes) 

(doI 1st (n2 nodes) 

(«> nl DUMPLINK n2 fp))) 

(close fp)) 

; PLOT makes ascii printer timeline files 
(defmethod Net PLOT (nlist cycles Sea ux fp) 

(setq fp (openo (FNAME ".pit"))) 

(dolist (n nlist) (■> n LABEL fp)) 

(PLABEL M 0.0 M '•©.S'* M 1.0" ” M fp) 

(PLABEL " +|- M M -j- M M -| M M - M fp) 

(-> self RUN cycles niI t fp) 

(close fp) 

(-> self REDRAW)) 


[continued) 
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; **************************************************** 
; * the Node object 

; **************************************************** 


(defclass Node Object 
(name 

value 
initval 
contr lb 
aline 
11 Inks 
alinks)) 


printing name 
activation value 
Initial value 
temp for col lection 
animation line 
Inhibition I inks 
activation I inks 


(defmethod Node isnew (nm ^optional val line) 

i setq name nm) 

setq value (setq initval (or val 0))) 
setq contrib 0) 
setq aline (or line 2)) 
self) 


; **************************************************** 

; * these methods do the actual arithmetic 
; * for spreading activation and lateral inhibition 
; **************************************************** 

(defmethod Node SEND (&aux c) ; Spread activation 
(cond ((not (zerop value)) 

(setq c (* value $ALV)) 

(doIist (I alInks) 

(«> I RECEIVE c)) 

(setq c (* value $ILV)) 

(do IIst (I iI Inks) 

(«> I RECEIVE c))))) 

(defmethod Node RECEIVE (val) ; collect activation 
(setq contrlb (+ contrib val))) 

; update value 

(defmethod Node UPDATE(fIag &aux newval) 

(setq contrib (min $RES (max (- $RES) 

(/ contrib $RES)))) 

(setq newval 

(cond ((minusp contrib) 

(+ value (/ (* contrib value) $RES))) 
(t (+ value 

(/ (* contrib 

(- $RES value)) 

$RES))))) 

(cond ((and flag (not (■ value newval))) ; animate 
(«> self ERASE) 

(setq vaIue newvaI) 

(«> self DRAW)) 

(t (setq value newval))) 

(setq contrib 0)) 

; **************************************************** 

; * these methods are for "graphic" display 

; **************************************************** 

(defmethod Node DRAW () ; "draw" node 

(GOTO aline (1+ (PSCALE value))) 

(princ name)) 

(defmethod Node ERASE () ; erase node 

(GOTO aline (1+ (PSCALE value))) 

(ERASETOEOL)) 

(defmethod Node SHOWTO (node &aux sum) ; grphic links 
(«> self DRAW) 

(princ " ") 

(setq sum (•> self BILINKS? node)) 

(princ (nth sum •(" " —> —o —* 

<— <-> <-o <-* 

o— o-> 0-0 0“* 

*— *-> *—0 *-*))) 

(and (eq self node) (princ "SHOWING")) 

(terpri)) 


100 BYTE LISTINGS SUPPLEMENT 







(defmethod Node PLOT (ol) ; put o char in plot 

(rplaca (nthcdr (PSCALE value) ol) 

(or (and (- “ " (nth (PSCALE value) ol)) 
(chr (+ 63 aline))) 

•'?“))) 

(defmethod Node LABEL (fp) ; make legend for plot 

(PRINTL ‘(.name - ,(chr (+ 63 aline))) fp)) 

; **************************************************** 

; * These are "predicates" used for querying a node 

; **************************************************** 

(defmethod Node LINKS? (node) ; what links to node? 
(+ (or (and (member node allnks) 1 ) 0 ) 

(or (and (member node Minks) 2) 0))) 

(defmethod Node BILINKS? (node) ; bidirectional links? 
(+ (-> self LINKS? node) 

(* 4 (•> node LINKS? self)))) 

(defmethod Node NAME? () ; whats your name? 

name) 

; **************************************************** 
; * the next methods are used in saving a file 

j **************************************************** 

(defmethod Node DUMP (fp) ; commands to add node 

(PRINTL *(m a .name) fp) 

(or (* 0 value) 

(PRINTL '(m s .name .value) fp))) 

; commands to link 

(defmethod Node DUMPLINK (node fp &aux I type) 

(seta I type (-> self LINKS? node)) 

(or (zerop (bit-and 1 Itype)) 

(PRINTL *(m I a .name .(«> node NAME?)) fp)) 
(or (zerop (bit-and 2 Itype)) 

(PRINTL '(ml i .name .(-> node NAME?)) fp))) 

; **************************************************** 

; * these methods modify nodes 

; **************************************************** 

(defmethod Node UNLINK (node) ; remove Iway links 

S setq allnks (delete node allnks)) 
setq II Inks (delete node iI inks))) 

(defmethod Node RESET Q 5 reset to initial val 

(setq value initval)) 

(defmethod Node SETVALUE (val) ; change the value 
(setq value (setq initval val))) 

(defmethod Node LINKTO (node type); create a link 
(or (zerop (bit-and 1 type)) 

(setq alinks (cons node allnks))) 

(or (zerop (bit-and 2 type)) 

(setq iI inks (cons node II inks))) 

(or (zerop (bit-and 12 type)) 

(«> node LINKTO self (/ type 4)))) 

(defmethod Node RENUM (line) ; change display line 
(setq aline I 1 ne)) 

(defmethod Node CLEARLINKS () ; fix circular 

(setq alinks (setq Minks nil))) ; lists for gc 
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so12.Isp 
TEXT 

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. 
February, page 189. 


(expand 45) ; make some space 

; **************************************************** 
; * edltnet Is the main routine 
; **************************************************** 


(defun edltnet (&aux net node It qflag) 
(setq net (■> Net new)) 

(CIS) 

(nuII qfIag) 


(while 

(gc) 

(MENU 

!? 


(s 

nil)) 


(Quit File Modify Execute Showlinks) 

(setq qflog t)) 

(MENU (Load Save Clear Plot) 

I (PUSH $FIIES (openl (FNAME ".net")))) 
s («> net SAVE)) 
c (-> net CLEAR)) 

p (-> net PLOT (-> net SUBNET) 

(PROMPT "how many cycles"))))) 

(m (MENU (Add-node Set-value Link Del-node Unlink) 

(a (setq node (PROMPT “name")) 

(*> net ADD (“> Node new node 0))) 

(s (setq node («> net FIND "node")) 

(-> node ERASE) 

(-> node SETVALUE (PROMPT "value")) 

(«> node DRAW)) 

(I (setq It (or (MENU 

(A—> I—o S<—> Xo-o Co->) 

(a 1)(l 2)(s 5)(x 10)(c 9)) 

0 )) 

(-> (.> net FIND "from") LINKTO 

(-> net FIND "to") It)) 

net DEL («> net FIND "name"))) 

(«> net FIND "from") UNLINK 
(-> net FIND "to"))))) 

(e (MENU (Reset Cycle) 

(r (-> net RESET)) 

(c (-> net RUN 

(PROMPT "how many cycles") 
t nil nil)))) 

(-> net SHOWLINKS (-> net FIND "node")))) 


(i is 


(ndefun MENU (Items &rest actions &aux command expr) 
(setq command (FIRST-CHAR (PROMPT items))) 

(do list (a act ions) 

(and (= (FIRST-CHAR (car a)) command) 

(setq expr (cons 'progn (cdr a))))) 

(eval expr)) 

(defun FIRST-CHAR (x) ; first case I ess char 

(blt-and 31 (ascii (symbol-name x)))) 


(defun PROMPT (str) 
(cond ($FILES 


read an atom 


(t 


(or (read (car $FILES)) 

(progn (close (car $FILES)) 

(setq $FILES (cdr $FILES)) 
(PROMPT str)))) 


(GOTO 1 1) 
(ERASETOEOL) 
(prlnc str) 
(prlnc "?") 
(read)))) 
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; **************************************************** 
; * support functions 

; **************************************************** 


(defun PLABEL (a b c char fp) ; used by 
(princ a fp) 

(dotimes (j (- (/ $PW 2) 3)) (princ 

S princ b fp) 

dotimes (j (- (/ $PW 2) 3)) (princ 
(princ c fp) 

(terpri fp)) 


(defun PRINTL (I fp) 

(dolist (x I) (princ x 
(terpri fp)) 


fp) 


; print 
(princ " 


PLOT 

char fp)) 
char fp)) 


Iist w/o paren 

" fp)) 


(defun FNAME (typ) 

(strcat (symbol-name (PROMPT 
(ndefun PUSH (stack item) 

(aval (list 'setq stack (I 


; make a fiIename str 
"file")) typ)) 

; standard macro 
ist 'cons item stack)))) 


(defun PSCALE (val) 

(/ (* $PW val) $RES)) 


; (0,100)—>(0,$PW-1) 


; **************************************************** 
; * GIobaI var tables 

; **************************************************** 


(setq $RES 100) 
(setq $PW 60) 
(setq $ALV 20) 
(setq $ILV -45) 
(setq $FILES nil) 


resolution of arith. 
prInting width 
activation link value 
inhibition I ink value 
stack of input files 


; **************************************************** 
; * primitives for handling screen updates 
; * below is for ANSI Standard; need to personalize 
; **************************************************** 


(defun GOTO (I in col) 
(princ "\e[") 
(princ lin) 
(write-char 59) 
(princ col) 

(princ *H)) 

(defun CLS () 

(princ "\e[2J")) 

(defun ERASETOEOL () 
(princ "\e[0K")) 


; move the cursor 

; clear the screen 
; ERASE to end of line 


; **************************************************** 
; * macros for nonquoted object handling 
; **************************************************** 


(ndefun defclass ; define a new class 

!! newclass superclass ivars) 
set newclass (Class ’new)) 

eval (list newclass ’’isnew superclass)) 
eval (list newclass ’’ivars 

(list 'quote ivars)))) 

(ndefun defmethod ; define a new method 

!! class selector args &rest body) 
eval (list class ’'answer (list 'quote selector) 
I 1st 'quote args) 

I ist 'quote body}))) 


(ndefun -> (class selector &rest args) ;SEND message 
(eval (cons class (cons (list 'quote selector) 

args)))) 


{continued) 
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• **************************************************** 
; * The Net object 

; **************************************************** 
(defclass Net Object 

(nodes ; just a list of nodes 

line)) ; and the next display line 

(defmethod Net isnew () 

(setq line 2) 
self) 

; **************************************************** 
; * query methods 

; **************************************************** 

(defmethod Net SUBNET (&aux I n) ; get a subnetwork 
(setq n (PROMPT "how many nodes")) 

(dotimes (i n (reverse I)) 

(PUSH I («> self FIND "node")))) 

(defmethod Net FIND (str &aux out name) ; get a node 
(whiIe (nu I I out) 

(setq name (PROMPT str)) 

(dolist (n nodes) 

(and (eq (*> n NAME?) name) 

(setq out n))) 

(setq str "the name of a node") 
out)) 


; **************************************************** 
; * method which modify networks 
; **************************************************** 

(defmethod Net ADD (node) ; add a node 

! setq nodes (nconc nodes (cons node nil))) 

-> node RENUM line) 
setq line (1+ I ine)) 

-> node DRAW)) 


(defmethod Net DEL (node) ; delete a node 

(dolist (n nodes) (■> n UNLINK node)) 

(setq nodes (delete node nodes)) 

(•> self RENUMBER)) 


(defmethod Net CLEAR () ; empty network 

(dolist (n nodes) (=> n CLEARLINKS)) 

(setq line 2) 

(setq nodes nil) 

(«> self REDRAW)) 

(defmethod Net RESET () ; reset all nodes 

(dolist (n nodes) («> n RESET)) 

(«> self REDRAW)) 


(defmethod Net RENUMBER () ; compact display 

(setq line 2) 

(doIist (n nodes) 

(«> n RENUM line) 

(setq line (1+ I ine))) 

(«> self REDRAW)) 


; **************************************************** 
; * methods for displaying, plotting, and saving nets 
; **************************************************** 


(defmethod Net REDRAW () ; REDRAW the screen 

(CLS) 

(dolist (n nodes) (=> n DRAW))) 

(defmethod Net SHOWLINKS (node) ; graph 1 node 
(CLS ) 

(dolist (n nodes) («> n SHOWTO node))) 

; RUN iterates n cycles and animates and/or plots 
(defmethod Net RUN (n aflag pflag fp &aux piine) 

(«> self REDRAW) 
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(ond pflog (dotlmes (I $PW) (PUSH pllne " "))) 
(dotimes (i n) 

(cond 
(pflag 

(prlnc (substr (strcat (Itoa i) " ") 1 3) 

/ fp ) ^ 

(princ fp) 

(mapllst '(lambda (x) (rplaca x " ")) 
pI Ine) 

(dolist (n nI 1st) (*> n PLOT pllne)) 

(do list (ch pllne) (princ ch fp)) 

(terpri fp))) 

(dotist (n nodes) («> n SEND)) 

(dolist (n nodes) (=> n UPDATE aflag)) 

(GOTO 1 1) 

(princ i) 

(terpri))) 

; SAVE creates a file with commands to recreate net 
(defmethod Net SAVE (&aux fp) 

(setq fp (openo (FNAME ".net"))) 

(do Iist 
(dolist 



(close fp)) 

; PLOT makes ascii printer timeline files 
(defmethod Net PLOT (nlist cycles &aux fp) 

(setq fp (openo (FNAME ".pit"))) 

(dolist (n nlist) (=> n LABEL fp)) 

(PLABEL " 0.0" "0.5" "1.0. fp) 

! PLABEL “ + |- M M -| M fp) 

■> self RUN cycles nil t fp) 
close fp) 

«> self REDRAW)) 

; **************************************************** 
; * the Node object 

; **************************************************** 
(defclass Node Object 


(name 


printing name 
activation value 
initial value 
temp for coI Iection 
animation line 
inhibition links 
activation links 


va I ue 


i nitvaI 
contrib 
aline 


i I inks 
a I Inks)) 


(defmethod Node isnew (nm val) 

(setq name nm) 

(setq value (setq initval val)) 

(setq contrib 0) 

(setq aline 2) 
self) 

; **************************************************** 
; * these methods do the actual arithmetic 
; * for spreading activation and lateral inhibition 
; **************************************************** 

(defmethod Node SEND (&aux c) ; Spread activation 
(cond ((not (zerop value)) 

(setq c (* value $ALV)) 

(doli81 (I alinks) 

S (»> I RECEIVE c)) 
setq c (* value $ILV)) 
dolist (I i I inks) 

(«> I RECEIVE c))))) 

(defmethod Node RECEIVE (val) ; collect activation 
(setq contrib (+ contrib val))) 


update value 


( continued ) 
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(defmethod Node UPDATE (flag &aux newval) 

(setq contrlb (min $RES (max (minus $RES) 

(/ contrlb $RES)))) 

(setq newval 

(cond ((minusp contrlb) 

(+ value (/ (* contrlb value) $RES))) 
(t (+ value 

(/ (* contrlb 

(- $RES value)) 

$RES))))) 

(cond ((and flag (not (■ value newval))) ; animate 
(-> self ERASE) 

(setq value newval) 

(-> self DRAW)) 

(t (setq value newval))) 

(setq contrlb 0)) 


; **************************************************** 
; * these methods are for "graphic" display 
; **************************************************** 


(defmethod Node DRAW () ; "draw" node 

(GOTO aline (1+ (PSCALE value))) 

(prlnc name)) 

(defmethod Node ERASE () ; erase node 

(GOTO aline (1+ (PSCALE value))) 

(ERASETOEOL)) 

(defmethod Node SHOWTO (node &aux sum) ; grphic links 
(»> self DRAW) 

(prlnc " ") 

(setq sum («> self BILINKS? node)) 

(prlnc (nth sum '(" " —> —o —* 

<— <-> <—o <-* 

o— o-> o-o o—* 

*— *-> *—o *-*))) 

(and (eq self node) (prlnc "SHOWING")) 

(terpri)) 

(defmethod Node PLOT (ol) ; put a char In plot 

(rplaca (nthcdr (PSCALE value) ol) 

(or (and (- " " (nth (PSCALE value) ol)) 
(chr (+ 63 aline))) 

"?"))) 

(defmethod Node LABEL (fp) ; make legend for plot 

(PRINTL (list name (chr (+ 63 aline))) fp)) 


; **************************************************** 
; * These are "predicates" used for querying a node 
; **************************************************** 

(defmethod Node LINKS? (node) ; what links to node? 
(+ (or (and (member node alinksj 1) 0) 

(or (and (member node Minks) 2) 0;)) 

(defmethod Node BILINKS? (node) ; bidirectional links? 
(+ («> self LINKS? node) 

(* 4 (*> node LINKS? self)))) 

(defmethod Node NAME? () ; whats your name? 

name) 


; **************************************************** 
; * the next methods are used in saving a file 
; **************************************************** 

(defmethod Node DUMP (fp) ; commands to add node 

(PRINTL (list *m 'a name) fp) 

(or (=* 0 value) 

(PRINTL (I i81 'm *s name value) fp))) 

; commands to link 

(defmethod Node DUMPLINK (node fp &aux I type) 

(setq I type (-> self LINKS? node)) 

(or (zerop (bit-and 1 Itype)) 
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(PRINTL (list 'm ’I ’a name («> node NAME?)) 
fp)) 

(or (zerop (bit-and 2 Itype)) 

(PRINTL (list ’m 'I 'i name (-> node NAME?)) 
fp))) 

; **************************************************** 

; * these methods modify nodes 

; **************************************************** 

(defmethod Node UNLINK (node) ; remove Iway links 
(setq alinks (delete node alinks)) 

(setq ilinks (delete node Minks;)) 

(defmethod Node RESET () ; reset to initial val 

(setq value initval)) 

(defmethod Node SETVALUE (val) ; change the value 
(setq value (setq initval val))) 

(defmethod Node LINKTO (node type); create a link 
(or (zerop (bit-and 1 type)) 

(setq alinks (cons node alinks))) 

(or (zerop (bit-and 2 type)) 

(setq Ilinks (cons node ilinks))) 

(or (zerop (bit-and 12 type)) 

(=> node LINKTO self (/ type 4)))) 

(defmethod Node RENUM (line) ; change display line 
(setq aline Iine)) 

(defmethod Node CLEARLINKS () ; fix circular 

(setq alinks (setq ilinks nil))) ; lists for gc 


• **************************************************** 
; * XLISP 1.4 quasi-compatible functions 
; **************************************************** 

(ndefun dolist (iexp &rest exprs) 

(mapcar (cons 'lambda (cons (list (car iexp)) 

exprs)) 

(eval (cadr iexp))) 

nil) 

(ndefun dotimes (iexp Screst exprs) 

(eval (list 'progn 

(list 'setq (car iexp) -1) 

(cons 'repeat 

(cons (cadr iexp) 

(cons (list * setq 

! car iexp) 

list '1+ (car iexp))) 
exprs)))))) 


defun zerop (x) (- x 0)) 
defun minusp (x) (< x 0;) 


stramdsk.c 
TEXT 

"Programming Tools and the Atari 520st", Bruce Webster. 

February, page 331. Also download ST.doc 

ALERT /* ALERT /* ALERT 

DOWNLOAD! ST.doc for the revised ST upgrade procedure 

DOWNLOADl ST.doc for the revised ST upgrade procedure 

DOWNLOAD! ST.doc for the revised ST upgrade procedure 

[continued) 
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RAM DISK ACCESSORY version 1.1 - sept 10. 1985, 

Gert Slavenburg, Mountain View, CA. 

For Atari 520ST with RAM extension to 1 MByte. 

Link this program with accstart,%1,osbind,vdibind,aesbind 

This Is the first, experimental version of the RAMdisk. It 
should be installed as a DESK ACCESSORY on the Bootdisk. 

(that is it should be called either DESKI,DESK2, or 
DESK3.ACC). Before re-booting, and thus activating It, the 
menu entry "install disk" should be used to install drive "D" 
with Icon-label "RAMDISK". Then save the desktop to make the 
newly installed drive permanent. Now re-boot end enjoy. 

(write protect if you're paranoid - I am) 

This version (1.1) avoids any directory knowledge by just 
copying the whole disk that it is booted on into the RAMdisk. 
This makes booting seem to take forever. Throw away any files 
on the RAMdisk that you don’t want by Just deleting them ! 

You may get annoyed by my trick to let the RAMdisk give a 
beep every 30 seconds. This was a debugging tool for me to 
see if it's still alive, and I get worried now if I don’t 
hear it anymore... To remove it, Just replace the "beep" 
statement in procedure "sleep". 

known bugs : 

1) GEMDOS refuses to do full diskette copy to/from the 

RAMdisk. Don't know why it does that, since the BPB's are 
identicaI. 

Lots of fun - Gert 

*/ 

^include "portab.h" 

^Include "obdefs.h" 

#incIude "define.h" 

#include "gemdefs.h" 

^include "osblnd.h" 

struct bpb 
.More.. 

\ WORD recsiz, /* see BIOS:rwabs.c for more info */ 

c I s I z, 
c I s izb, 
rdIen, 
fsiz, 
fatrec, 
datrec, 
numcI, 
bfIags; 


/* 


/* stupid AES binding arrays - what a drag */ 


int contrI[12]; 
int intin[1281; 
int ptsin[128J; 
int intout[l28l; 
int ptsout[l28J; 


/* better find out what’s REALLY NEEDED ★/ 


/* the variables below are really serious */ 

# 

typedef LONG (*PFL)(); /* define "pointer to function returning a long" */ 
typedef WORD (*PFW)(); /* define "pointer to function returning a word" */ 


PFL getbpb; 
PFW mediach; 
PFL rwabs; 


/* pointer to the systems original getbpb function */ 

/* pointer to the systems original mediach */ 

/* pointer to the systems original rwabs */ 


struct bpb rdiskbpb = { 512, 2, 1024, 7, 5, 6. 18, 351, 0 

/* same as Single Sided microdiskette */ 

Int data[184320]; /* 720 sectors of 512 bytes */ 

/* same as Single Sided microdiskette */ 
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LONG RDgetbpb(dev) 

WORD dev; 

* if (dev !« 3) 

return( (*getbpb)(dev) ); /* pass all non-RAMdisk to old handler */ 

e I se 

} return( fcrdiskbpb ); /* return our bpb */ 

} 1 


WORD RDmediach(dev) 

WORD dev; 

if (dev I* 3) 

return((*mediach)(dev)) ; /* pass all non-RAMdisk to old handler */ 

e I se 

return( 0 ); /* RAMDISK media never changes */ 


LONG RDrwabs(rw,buf.count,recno.dev) 
WORD rw; 
int *buf; 

WORD count, recno, dev; 

I int I, *p; 


if (dev 1- 3) 

return( (*rwabs)(rw,buf,count,recno,dev) ); /* pass it on */ 
else 

\ if (rw > 1) rw —2; /* we never change media anyway */ 

while ( count > 0 ) 

{ p * &data[((long) recno) * 256L];/* both casts necessary - C068 bug */ 
if (rw**0) /* read */ 

for (i«0; 1<256; i++) *buf++ « *p++; 
else /* write */ 

for (i=0; i<256; i++) *p++ ■ *buf++; 
count—; recno++; 

return(0L); 

i 


instalI() /* take over DISKIO vectors. MUST RUN AS SUPERVISOR */ 

{ 

long *bpbvect « 0x472; 
long erwvect * 0x476; 
long *mcvect ■ 0x47e; 
long *devset ■ 0x4c2; 

getbpb * *bpbvect; /* save old vectors */ 

mediach = (PFW) *mcvect; 
rwabs * (PFL) *rwvect; 

♦bpbvect * RDgetbpb; /* install new ones */ 

*mcvect « RDmediach; 

♦rwvect ■ RDrwabs; 

/* vectors set-up, include in deviceset : */ 
♦devset « (>»«devset) | (0x8L); 




sleep() /* sleep forever */ 

\ int i; 
while (1) 

{ i « evnt_timer(30000,0); /* wait 30 Sec. */ 
Bconout(2,7); /* BEEP to show I’m alive */ 


main() 

appl-Inlt(); 

Rwabs(0,dota,720,0,0); 

xbios(38,InstalI); 
s I eep(); 


/* this Is needed even to link - Yack 111! 111 */ 

/* copy drive A: into RAMdlsk data array */ 

/* INSTALL vectors in SUPV MODE */ 

/* accessories never end . */ 


( continued ) 
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St.doc 
TEXT 

"Programming Tools and the Atari 520ST", Bruce Webster. 
February, page 331. Also download ST2.doc. 


atari/tech.st #239, from bwebster, 14398 chars, Thu Jan 30 23:46:40 1986 


TITLE: *** ALERT! ALERT! ALERT! *** 

Checked into my arpa/uucp mail node for the first time in about a month 
and found the following message. Could make for some interesting complaints 
about the Feb BEST OF BIX section. 


This is a modification to gert's original posting. You should 
read it carefully if you are planning to upgrade your ST as 
there are some important modifications. I got this from a 
posting on net.micro.atari. 


>From bammi@cwruecmp.UUCP (Jwahar R. Bammi) Wed Dec 18 13:09:35 1985 
Path: umcp-cs!seismo!harvard!thInk!mit-eddie!genrad!decvax!cwruecmp!bammi 
Newsgroups: net.micro.atarI 

Subject: Re: one meg upgrades - PLEASE READ or fry your ST 
References: <157@lmagen.UUCP> 

> NWMWMWMNMWMWMMMMMMMpO p gOSS the ST~~~~~~~~~~~~~~~~~~~ 

> 

> i just fried my ST and after talking to atari and my local dealer i 

> have tracked down the problem. It is related to the 1 Meg upgrade 

> and the new proms, it seems that the early postings of "how to 

> upgrade ...." left out 4 critical resisters (60 ohm 10% tol); 2 must 

> be placed on the CAS lines and 2 on the RAS lines, all 4 go on the 

> MMU (i know it isnt really an MMU) side, the upgrade will work fine 

> w/o the resistors until you put in the new proms, the difference in 

> the current drain will cost you all your memory chips and possibly 

> the MMU. 

> — 

> god bless LIly St. Cyr 

> -Rocky Horror Picture Show 

> 

> Name: James Turner 

> Mail: Imogen Corp. 2650 San Tomas Expressway, P.0. Box 58101 

> Santa Clara, CA 95052-9400 

> AT&T: (408) 986-9400 

> UUCP: ...{decvax,ucbvax}!decwrI!imagen!turner 

After reading the above article, I downloaded the revised procedure 
from Compu Serve. I have had the upgrade for about 3 months, and has 
worked without a flaw. I would have probably added the proms without 
the resistors. Thanks to Mr. Turner for the warning. 

Here is a copy of the revised procedure: 

NOTE: This is an REVISED,TESTED version of the original text 
downloaded from CompuServe. December 6, 1985 

(This was REVISED AND TESTED by an annonymous engineer on 
Atari's developement staff. The addition of the resistors 
should provide a long life to your machine, but the warning 
below is STILL IN EFFECT. This is not an official sanction 
of the modification. USE WITH CARE!!!) 

Here's the 1 Meg upgrade directions: 

I have brought this over un-editted from the arpanet info-st 
mailing list. I TAKE NO RESPONSIBILITY FOR ITS CONTENT OR 
ACCURACY. I HAVE NOT TRIED THIS MODIFICATION ON MY OWN ST AS 
YET. I AM PASSING THIS ALONG TO THOSE WHO DO WISH TO TRY IT. 

FOLLOW THE DIRECTIONS AT YOUR OWN RISK. 

—Dwight McKay (75776,1521) 

From: gert@pescadero 
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WARNING: This is a hardware modification that will void the 
warranty of your 520ST. If you do not have the appropriate 
tools or experience you have a substantial chance of ruining 
your 520ST. Proceed at your own risk! This modification has 
been in my 520ST without any problems for 6 days now. 
However, I have (of course) not checked with knowledgable 
sources at Atari to verify if this modification endangers 
the long term machine reliability and/or software 
compatibility (I suspect it may endanger their software 
compatibility if enough of us do it!) 

Tools & components needed : 

16 256k * 1 RAM chips, 150 ns access time type, e. g. NEC 

41256C-15 (avilable at e. g. Fry's Electronics, Sunnyvale, 

CA for $2.77 each) 

A good quality, preferrably temperature controlled soldering 
iron, with a minature tip (tip should be narrow enough to 
avoid touching 2 I. C. pins at the same time). E. g. Weller 
type soldering station. 

Good quality resin core solder (thin). 

Approximately 4 foot of #24 AWG insulated wire and a good 
stripper for it and 2 feet of #22 AWG solid tinned copper 
bus wire. You will have to route 3 wires over a sequence if 
I.C. pins. 

Desoldering wick and solder suction tool. 

Philips typ e screwdriver (for opening your ST), tweezers 
pI iers, etc. 

A steady hand and self-confidence. 

Explaination of the modification : 

(Please read the rest of this document before starting. It 
may save you time and an 520ST) 

The current memory inside the 530ST consists of 16 256K*1 

RAM chips. Address (A0..A8) lines are common to all those 

chips. The WriteEnable line is also common to all chips. 

Data (in and out} lines are of course individual. The RAS 
(row-address strobe) line is common to all chips. The 8 chis 
foring the high order byte group have one common CAS line, 
and the 8 forming the low order byte group have one common 
CAS line (CAS is used as enable for write operations, such 
that WriteEnable can be common to both groups). The high 
order group from MSB to LSB consists of U45, 44, 43, 42, 38, 

34, 33, 32. The low order group of U30, 29, 28, 25, 24, 28, 

27, 26. Note that all chips are adjacent, though the 

numbering has gaps. RAS0, CAS0H, and CAS0L are supplied from 
U1 pin 8,6 and 7 respectively (The 0 indicates bank 0) 

Bank 1 that you are going to build in will be "piggy-backed" 
on top of the current chips, where all pins of the new chips 
EXCEPT RAS (pin 4) and CAS (pin 15) are soldered to the old 
chips equivalent pins. Thus they will end up sharing 
addresses, data, WriteEnable and power and ground with the 
existing chips. 

All RAS pis of the new chips are wired together and will be 
supplied with the "RASI" signal generated on pin 18 of U15 
(the memory controller, marked 3H-2119C or so). The CAS pins 
of the 8 new high order byte chips (on top of U45..U32) are 
wired together and supplied from the "CAS1H" signal 
generated on pin 22 of U15. Analogously, the CAS pins of the 
new U30 to U16 are wired together and supplied with "CASH" 
from pin 21 of U15. 

How to go about it: 

Step 1: Open up your 520ST, pull off the keyboard connector 



February 


and remove the main circuit card from its top and bottom 
shielding. Make sure to remember which screws go where and 
note the keyboard connector orientation. 


Step 2: Oesolder all of 
existing RAM chips. (DO NOT 
if you do, and worse, the 
since you can't solder 
rellably (If at all)). To 
to heat the island on the 
wires straight. After do 
over to the component side 
the capacitor out with the 


the capacitors adjacent to the 
SKIP THIS STEP. You'll lose time 
modification will no be reliable 
pins obstructed by the capacitors 
desolder them, I found it easiest 
non component side, and bend the 
ing that or each capacitor, turn 
and heat the islands wile pulling 
tweezers. 


Step 3: Open up the holes of all the desoldered capacitors, 
using a combiation of de-soldering wick and suction tool. Do 
this from the non component side. If certain holes are 
difficult to open up, you may want to use a wood splinter, 
(push it through while heating). Be careful I to remove all 
solder debris!! THE REASON for opening the holes NOW is that 
they will be less accessible once you've done the other 
steps! Patience is a virtue. 

(NOTE: Step 2 k 3 are the only ones that may damage your ST 
PC board. Be sure not to use excessive force while pul I Iing 
out the capacitors. If you damage your PC board anyway, cure 
the problem now and not later). 

Step 4: In this step we will piggyback the new RAM's on top 
of the old oes. Be sure to connect all pins except pin 4 
(RAS) and 15 (CAS). The best way to go about this is to do 
chip by chip. First, bend the pins of the new RAM's suchthat 
hey are perpendicular to the package (instead of having 
slightly spread "cowboy legs"). Use pliers to bend pin 4 and 

15 such that the legs are 180 degrees from their normal 
position, so they stick up in the air above the plane of the 
top surface of the chips. Don't make an absolute sharp 180 
degree bend since some manufacturers' pins may snap off. 
Leave a little curve in the leg, but insure that is above 
the plane of the top surface of the chip. 

Using #22 AWG to #16 AWG tinned solid copper wire you will 
form three buses along the top surface of the new d-rams. 
Cut a #22 AWG solid copper wire the length of the 16 d-rams 
on the PCB. The RAS bus is formed by soldering all the pin 
4's of the new d-rams to the solid copper wire. The bus wire 
must be seated against the top surface of the new d-rams 
without a gap. This insures clearance between the top shield 
and the pins of the d-rams. 

After soldering all 16 d-rams to the bus clip off any 
portion of the pins that extend above the top of the bus 
wire. Now cut a #22 AWG solid copper wire the length of the 

16 d-rams. Place the bus wire along the top surface of the 
new d-rams in contact with all the pin 15's of the new 
d-rams. Solder every pin 15 to this bus and as above insure 
that the wire is seated solidly against the top surface of 
the new d-rams. Cut off all excess pin length sticking up 
above the top of the bus wire. Using diagonal cutters remove 
the section of the bus connecting the new U30 pin 15 to the 
new U32 pin 15. This divides the bus in half with the new 
U16, 17, 18, 24, 28, 29 having a common pin 15. The new U32, 
33, 34, 38, 42, 43, 44, 45 now have a common pin 15, 
seperated from the other common bus. 


(NOTE: until step 6 is finished, do no i 
power to your ST. This intermediate state 
damage your memory chips!!) 


n any way apply 
of affairs will 


Step 5: Remount all the desoldered capacitors. Bend the pins 
like they were before resoldering, suchthat they wiI I not 
touch the lower shielding. Solder from the non component 
side. 

Step 6: Orient the 520ST PCB so that you are looking at the 
solder side of the PCB (non-component side), with the row of 
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d-rams nearest you. Find the double square pattern of pads 
at the 68-pin socket of the memory controller, U15 (3H2119). 
The following is a guide to locating the six memory 
controller pins necessary to complete the wiring. The socket 
is numbered contercIockwise, starting with pin 1, the square 
pad (look closely) in the middle of the bottom outside row. 
The sequence, moving counterclockwise from pin 1, first on 
the outside square ONLY: (NOTE: the sequence ")(" means to 
make a 90-degree turn counterclockwise, i.e. around the 
corner) 

1,3,5,7,9)(10,12,14,1*6,18,20,22,24,26)(27,29,31,33,35,37,39, 
41,43)(44,46.48,50,52,54,56,58,60)(61,63,65,67 

The sequence, moving counterclockwise along the inside 
square only, and starting with the left side of the bottom 
row: 

(62.64,66,68,2,4,6.8)(11,13,15,17,19,21,23,25)(28,30,32,34,3 
6,38,40,42)(45.47,49,51,53,55,57,59) 

Six 68-ohm 1/4W plus/minus 10% carbon film resistors must be 
added when adding memory. These series terminating resistors 
minimize undershoot which may damage BOTH BANKS of d-rams if 
omitted. Solder a 68-ohm resistor to pin 18 of U15, RAS1. 
Solder a #24 AWG stranded wire from the remaining end of the 
68 -ohm resistor to the pin 4 bus (RAS) of all the new 
d-rams. that is the new U16, 17, 18, 24, 25, 28, 29, 30, 32, 
33, 34, 38, 42, 43, 44, and 45. 


Solder a 68-ohm resistor to pin 22 of U15, CASH1. Solder a 
#24 AWG stranded wire from the remaining end of the 68-ohm 
resistor to pin 15 bus (CAS) of the new 
U45,44,43.42,38,34,33,32. 

Solder a 68-ohm resistor to pin 21 of U15, CASH. Solder a 
#24 AWG stranded wire from the remaining end of the 68-ohm 
resistor to pin 15 bus (CAS) of the new U30, 
29,28,25,24,18.17,16. 

For best results in all three cases above solder the wires 
coming from the resistors to the middle of the three bus 
wires in a "T" fashion rather than at one end of the buses. 


Use a continuity tester to find the following three traces 
— do not depend on visual inspection. Now install three 
68 -ohm series terminating resistors in the original 512K 
bank of ram. Be very careful while soldering to these narrow 
traces, since excessive heat can easily lift a trace from 
the board. Use an Exacto knife to gently remove solder mask 
from traces. 


Cut the trace leading from pin 8, RAS0, of U15 near U15. 
Solder a 68-ohm resistor in series with the trace. 


Cut the trace leading from pin 6, CAS0H, of U15 near U15. 
Solder a 68-ohm resistor in series with the trace. 


Cut the trace leading from pin 7, CAS0L, of U15 near U15. 
Solder a 68-ohm resistor in series with the trace. 


Step 7: Sit back. Use Brain. Do you feel confident about the 
quality of your work? No mistakes? Check evrythlng once 
again if you are but a little uncertain. Applying power with 
errors might make your ST into a decorative, nonfunctional 
piece of art. OK. Either rebuild your ST into its shielding 
and cabinet, or put it onto a surface clear of wires and 
solder remians and connect It to monitor, disk and supply. 
Boot It. 


It It boots, you're probably there. Test if the new memory 
works by looking at the phystop variable ($42E) with SID if 
you have the developer stuff. It should read $100000 (1M 
hex). Also note that memcntlr ($424) now holds 5 instead of 
4, and that v_bas_ad ($44E) now holds $F80000 (screen bitmap 


[continued) 
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origin). If you don't have the developer stuff, try a single 
drive copy and check that you get the whole disk In one 
buffer Instead of two. 

If the new memory does not seem to exist, use SID to deposit 
and retrieve words on locations $80000 and up (1/2 Meg hex). 
If bit errors occur, the ST bootROM did not detect the 
extension (it checks ail bits of 512 locations by testing a 
psedo random sequence, before accepting a memory bank). Try 
to pin point the faulty chip(s) and remove the error. 

If It doesn't boot, you're in trouble. I'm sorry. It is 
difficult to give hints on what to do here. So many 
possibilities. Desoldering the new chips probably won't work 
(if the old ones were functional, the ST would still boot). 
Check for hidden short:circuit on the RAM pins. May also be 
that you have a flaky new pin connection. 

That's alI there is... 


Usenet: 
CSnet: 
Arpa: 
CompuServe: 


Jwahar R. Bammi 

.!decvax!cwruecmp!bammi 

bammi@case 

bammi%case@csnet-reI ay 
71515,155 


gimpeI.Ibr 
BINARY 

"Processing Strings in Snobol4," James F. Gimpel. 

February, page 175. Download lu.exe to unpack this library. 


LOWS ■ 'abcdefghijkImnopqrstuvwxyz* 

UPS = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ* 

INPUT( 'NAMES', 2 ) 

PATTERN = TRIM(NAMES) 

L00P1 PATTERN = PATTERN | TRIM(NAMES) :S(L00P1) 

PATTERN - PATTERN . NM 

L00P2 LINE - INPUT :F(END) 

L00P3 LINE PATTERN = REPLACE(NM, LOWS, UPS ) :S(L00P3) 

OUTPUT = LINE :(L00P2) 

END 


LISTING2.TXT 

DEFINE( 'ROMAN(N)T') :(ROMAN_END) 

ROMAN N RPOS(1) LEN(1) . T :F(RETURN) 

•0,1I,2II,3III,4IV,5V,6VI,7VII,8VIII,9IX,' 

+ T BREAK(',') . T 

ROMAN « REPLACE( ROMAN(N),*IVXLCDM*,'XLCDM**') T 
+ :S(RETURN)F(FRETURN) 

ROMAN_END 


LISTING3.TXT 


DEFINE ( 'SELECT(S)N* ) 
N 


SELECT 

S RPOS(1) LEN(1) 

N = RANDOM(N) 

S (N-1) ARB . SELECT N 
SELECT_END 

DEFS - TABLEQ 


:(SELECT_END) 


: (RETURN) 


DEFS 

DEFS 

DEFS 

STACK 


'SENT' 
'NOUN' 
'VERB' 

= '<SENT> 


*0The <NOUN> <VERB>s the <N0UN>1' 
'0boy1man2dog3<NOUN> who <VERB>s the <N0UN>4' 
'0bitelwaIk2pet3Iick4smack5* 


LI 

L2 


SENTENCE * 

STACK POS(0) '<' BREAK('>') . NM '>' 
STACK * SELECT( DEFS[NM] ) STACK 
STACK BREAK('<') .S = 


F(L2) 

(LI) 

F(L3) 
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SENTENCE - SENTENCE S :(L1) 

13 SENTENCE * SENTENCE STACK 


LISTING4.TXT 



DEFINE( ’PUSH(X)’ ) 

DEFINE( ’POP()’ ) 

DEFINE( ’TOP()’) 

DATA( ’LINK(NEXT,VALUE)’ ) 

:(STACK_END) 

PUSH 

PUSH.POP - LINK( PUSH.POP, X ) 



PUSH - .VALUE( PUSH_POP ) 

:(NRETURN) 

POP 

IDENT( PUSH_POP) 

:S(FRETURN) 


POP - VALUE(PUSH.POP) 

PUSH_POP « NEXT( PUSH_POP ) 

:(RETURN) 

TOP 

IDENT( PUSH_POP) 

:S(FRETURN) 


TOP = .VALUE( PUSH.POP ) 

:(NRETURN) 


STACK.END 


LISTING5.TXT 

LET = ’ABCDEFGHIJKLMNOPQRSTUVWXYZ’ 

DIGITS = ’0123456789’ 

IDEN - (ANY(LET) (SPAN(LET DIGITS) | ”)) . *PUSH() 

+ NULL . *EV() 

INTEGER - SPAN(DIGITS) . *PUSH() 

PRIMARY - IDEN | INTEGER | ’(’ *E ’)’ 

FACTOR - PRIMARY | ’-* PRIMARY . *NEG() 

TERM * FACTOR 

+ ARBNO( FACTOR . *MUL() | •/• FACTOR . *DIV() ) 

E = TERM ARBNO( ’ + ’ TERM . *ADD() | TERM . *SUB() ) 


dvorak.bas 
TEXT 

"Keyboard Efficiency," Donald W. Olson and Laurie E. Jasinski. 
February, page 241. Also download dvorak.txt. 


100 TEXT : HOME : VTAB 10 

110 PRINT "QWERTY VS. DVORAK" 

120 PRINT 

130 PRINT "BY D.W.OLSON AND L.E.JASINSKI" 

140 DIM LA$(2),LI$(200),CH$(40),AA(40) 

150 DIM FI(122.2),x(l22,2).Y(122.2).SK(122,2) 
160 DIM CX(8,2),CY(8,2),DS(4,6) 

170 DIM FT(8,2),HT(2,2),GT(2) 

180 GOSUB 1000:SP - - 16336 

200 REM MENU 

210 HOME : VTAB 10 

220 PRINT "1..START NEW FILE (ZEROS TOTALS)" 
230 PRINT : PRINT "2..ADD TO CURRENT FILE" 

240 PRINT : PRINT ”3..PRINT HARD COPY" 

250 PRINT : INPUT A 

260 ON A GOTO 300,400,900: GOTO 200 

300 REM START NEW FILE 

310 NL » 0:NW - 0:AA(0) - 32:CL - 1 

320 FOR K » 1 TO 2: FOR F = 1 TO 8 

330 FT(F.K) •= 0:CX(F,K) - 0:CY(F,K) - 0 

340 NEXT : NEXT 

350 HOME : GOSUB 500: GOTO 600 

400 REM ADD TO CURRENT FILE 

410 HOME : VTAB 23: PRINT LI$(NL) 

420 PRINT : GOSUB 500: GOTO 600 

500 REM PRINT TOTALS 


A 
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510 

515 

520 

530 

540 

550 

555 

560 

570 

580 

585 

590 

595 

600 

610 

620 

625 

630 

635 

640 

645 

650 

655 

660 

665 

670 

675 

680 

685 

690 

700 

710 

720 

730 

735 

740 

745 

750 

755 

760 


HTAB 1: FOR I - 1 TO 12 
VTAB Is CALL - 868: NEXT 
VTAB Is HTAB 26: PRINT "<ESC: 
PRINT "AFTER ";NW;" WORDS: 


MENU>" 

PRINT 


1 


+ FT(1,K) + FT(2,K 


FT(6 


FOR K = 

HT(1,K) 

HT(2,K) 

GT(K) - 
INVERSE 
NORMAL 
PRINT " 

FOR F - 
NEXT 
REM 
NL = 

VTAB 
HTAB 
FOR J 

GET CH$(J):AC - ASC (CH$(J)):AA(J) - 
IF AC > 31 AND AC < 123 THEN 670 
AC = 13 THEN LL * J: GOTO 680 

> 1 THEN PRINT CHR$ 
= 1 THEN GOTO 635 
NL - NL - 1: GOTO 200 


»K) + FT(3,K) + FT(4,K)) 
»K) + FT(7, K) + FT(8,K)) 


TO 2 

* INT (0.5 

* INT (0.5 + FT(5,K 
HT(1, K) + HT(2,K) 

: PRINT LA$(K);TOTAL INCHES: ";GT(K) 
PRINT "LEFT HAND: ";HT(1,K); SPC( 5 - LEN 
RIGHT HAND: ";HT(2,K) 

1 TO 8:AX * INT (0.5 + FT(F,K)): PRINT AX; 
F: PRINT : NEXT K: RETURN 
GET NEXT LINE 
NL + Is POKE - 16368,0 
23: HTAB 39: PRINT "|"; 

Is PRINT CHR$ (7); 

1 TO 38 

AC 


( STR$(HT(1»K)))); 

SPC( 5 - LEN ( STR$ (AX))); 


IF 

IF 

IF 

IF 


AC « 8 AND J 
AC = 8 AND J 
AC * 27 THEN 
GOTO 635 

PRINT CH$(J);: IF J > 31 THEN PRINT CHR$ (7); 
NEXT J:LL = 39 


(8); CHR$ (32); CHR$ (8);:J * J - 1: GOTO 635 


CH$(LL) 

LI$(NL) 


* 32 
1 TO 


LL 


":AA(LL) 

: FOR J 

LI$(NL) = LI$(NL) + CH$(J): NEXT 
REM ANALYZE LINE NUMBER NL 
HTAB 1: CALL - 868 
FOR J - 1 TO LL 

PRINT CH$(J);:AC * AA(J): IF AC 
IF AC > 96 THEN CL = 0 
IF AA(J) = 32 AND AA(J - 1) < : 
IF AA(J) - 32 AND AA(J - 1) » 4! 
FOR K = 1 TO 2:F - FI(AC,K) 


< > 32 THEN AX * PEEK (SP) + PEEK (SP) 

► 32 THEN NW - NW + 1 

> THEN NW - NW - 1 


II 
JJ 

765 CX(F,K) 
770 FT(F,K) 
775 SF 


y{ac!k) - CY( 


X(AC,K) - CX(F,K 


X (AC, K 
FT(F 

SK(AC,K): IF 


F.K) + 
F ,K) + 


,K):CY(F,K) = Y(AC.K) 
, K) + DS(II.JJ) 


CL 


AND AC > 

780 IF SF > 0 AND SK(AA(J - 1),K) < 

790 NEXT : NEXT : PRINT : PRINT 
795 GOSUB 810: GOSUB 500: GOTO 600 
800 REM FINGERS TO HOME ROW 
810 FOR K = 1 TO 2: FOR F = 1 TO 8 
820 IF CX(F.K) = 0 AND CY(F.K) = 0 THEN 
830 II « 2 - CX(F,K):JJ = 3 - CY(F,K) 

840 FT(F,K) = FT(F,K) + DS(II,JJ) 

850 CX(F,K) = 0:CY(F,K) = 0 

860 NEXT : NEXT : RETURN 

900 REM PRINT HARD COPY 

910 IF NL = 0 THEN 200 

920 PRINT : PRINT CHR$ (4);"PR#1" 

930 PRINT : PRINT : GOSUB 530: PRINT : PRINT 
940 FOR I = 1 TO NL: PRINT LI$(I): NEXT I 
950 PRINT : PRINT CHR$ (4);"PR#0" 

960 GOTO 200 

1000 REM KEYBOARD DATA 


64 AND AC < 91 THEN 790 
> SF THEN FT(SF,K) = FT(SF,K) +2.25 


GOTO 860 


1005 LA$(1) = "QWERTY 
1010 READ AC: IF AC « 
READ N$: FOR K > 


":LA$(2) = "DVORAK " 
999 THEN 1200 
1015 READ N$: FOR K = 1 TO 2 
1020 READ FI(AC,K),X(AC,K),Y(AC,K),SK(AC,K) 
1025 NEXT K: GOTO 1010 

1032 DATA 32.SPACE,0,0,0,0,0,0,0,0 

1033 DATA 33,!,1,0,2,8.1,0,2,8 

1034 DATA 34,QUOTES,8,1,0,1,1,0,1,8 

1035 DATA 35.#.3,0,2,8,3,0,2,8 

1036 DATA 36,$.4.0,2,8,4,0,2,8 

1037 DATA 37,%,4,1,2,8,4,1,2,8 

1038 DATA 38.&,5,0,2,1,5.0.2.1 

1039 DATA 39,APOSTROPHE,8,1,0,0,1,0,1,0 

1040 DATA 40,(.7,0,2,1.7,0,2,1 

1041 DATA 41.),8,0.2.1,8,0,2,1 
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1042 DATA 42.*,6.0,2,1,6.0,2,1 

1043 DATA 43,+.8,2.2.1.8,2,1.1 

1044 DATA 44,COMMA.6,0,-1,0,2,0,1,0 

1045 DATA 45,-.8,1,2,0.8,1,0,0 

1046 DATA 46,..7,0,-1,0,3,0,1,0 

1047 OATA 47,/,8,0,-1,0,8,1,1,0 

1048 DATA 48.0,8,0,2.0,8,0,2,0 

1049 DATA 49,1,1,0,2,0,1,0,2,0 

1050 DATA 50,2.2,0,2,0.2,0,2,0 

1051 DATA 51,3.3,0,2.0,3.0.2,0 

1052 DATA 52,4,4,0,2.0,4,0,2,0 

1053 DATA 53,5,4,1,2,0,4,1,2,0 

1054 DATA 54,6,5.-1.2,0,5,-1,2,0 

1055 DATA 55,7,5,0,2,0.5,0,2,0 

1056 DATA 56,8,6,0,2.0,6,0,2,0 

1057 DATA 57.9.7,0.2.0,7.0,2,0 

1058 DATA 58,COLON,8,0.0,1,1,0,-1,8 

1059 DATA 59,SEMICOLON,8,0,0,0,1,0,-1,0 

1060 DATA 60,<.6.0,-1,1,2,0.1,8 

1061 DATA 61,-.8,2,2,0.8,2,1,0 

1062 DATA 62,>,7.0,-1,1,3,0,1,8 

1063 DATA 63,?,8,0,-1,1.8,1,1,1 

1064 DATA 64,@.2,0,2,8,2.0,2,8 

1065 DATA 65.A,1,0,0,8,1,0,0,8 

1066 DATA 66,B,4,1,-1,8.5,-1,-1,1 

1067 DATA 67,C.3,0,-1,8,6,0,1,1 

1068 OATA 68,D,3,0,0,8.5.-1,0,1 

1069 DATA 69,E.3,0.1,8,3,0,0,8 

1070 DATA 70,F,4,0.0.8,5,-1,1,1 

1071 DATA 71,G.4,1,0,8,5,0,1,1 

1072 DATA 72,H.5,-1.0.1.5.0,0,1 

1073 DATA 73,1,6.0,1,1.4.1,0,8 

1074 DATA 74,J,5,0,0,1,3,0,-1,8 

1075 DATA 75,K,6,0,0,1 ,4,0,-1 ,8 

1076 DATA 76,L,7.0,0,1,8,0,1,1 

1077 DATA 77,M,5,0,-1,1,5,0,-1,1 

1078 DATA 78,N.5.-1,-1,1,7,0,0,1 

1079 DATA 79,0,7.0,1,1,2,0,0,8 

1080 DATA 80,P,8,0,1,1,4,0.1,8 

1081 DATA 81,Q,1,0,1,8,2,0,-1,8 

1082 DATA 82,R,4,0,1,8,7,0,1,1 

1083 DATA 83,S,2,0,0,8,8,0,0,1 

1084 DATA 84,T,4,1,1,8,6,0,0,1 

1085 DATA 85,U,5,0,1,1,4,0,0,8 

1086 DATA 86,V,4,0,-1,8,7,0,-1,1 

1087 DATA 87,W,2,0,1,8,6,0,-1,1 

1088 DATA 88,X,2,0,-1,8,4,1,-1,8 

1089 DATA 89,Y,5,-1.1.1,4,1.1,8 

1090 DATA 90.Z,1,0,-1.8,8,0,-1,1 

1091 DATA 91,[.8.1,1,0,8,1,2,0 

1092 DATA 92.\.8.3.1,0,8.3,1.0 

1093 DATA 93.],8.2,1,0,8.2,2,0 

1094 DATA 94,*,5,-1,2,1,5,-1,2,1 

1095 DATA 95,_,8.1,2.1,8,1,0.1 

1096 DATA 96.',1,-2,-2.0,1,-2.-2.0 
1123 DATA 999 

1200 FOR I - 65 TO 90:AC -1+32 
1210 FOR K = 1 TO 2 
1220 FI(AC.K) = FI(I,K):SK(AC,K) = 0 
1230 X(AC.K) - X(I,K):Y(AC,K) = Y(I,K) 

1240 NEXT K: NEXT I 

1300 REM KEYBOARD SPACINGS 

1310 U - ,75:V = ,81:AN =90+23 

1320 DP = U * V * COS (AN * 3.1416 / 180) 

1330 FOR I = 0 TO 4: FOR J = 0 TO 6 
1340 DX - I - 2:DY - J - 3 

1350 DS(I.J) = SQR (DX * DX * U * U + DY * DY * V * V + 2 * DX * DY * 
1360 NEXT J: NEXT I: RETURN 


DP) 


(continued) 
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TEXT 

"Turbo Pascal 3.0" Mark Bridger. 
February, page 281 


program puzzIe; 

(* A compute-bound program from Forest Baskett *) 


const 

size - 511; 
classMax ■ 3; 
typeMax » 12; 
d »8; 

type 

pieceClass ■ 

pieceType - 

position * 

var 

pieceCount : 

class : 

pieceMax : 

puzzle : 

P : 

m,n : 

• »j»k : 

kount : 

function fit (I : 
label 1; 
var 


0..cIassMax; 
0..typeMax; 
0 ..sIze; 


array 
array 
array 
array 
array 
posItIon; 
0..13; 


pieceClass] of 0..13; 
pieceType] of pieceClass; 
pieceType] of position; 
position] of boolean; 
pieceType, position] of boolean; 


integer; 

pieceType; j : position) : boolean; 


k: position; 

begin fit :« false; for k := 0 to pieceMax[i] do 
if p[l,k] then If puzzle[J+k] then goto 1; 
fit :■ true; 

Is 


end; 


function place (l : pieceType; J : position) ; position; 

label 1; 

var 

k: position; 
begin 

for k := 0 to pieceMax[i] do 
if p[i,k] then puzzle[j+k] := true; 
pieceCount[class[i]] := pieceCount[cI ass[i]] - 1; 
for k j to size do 
If not puzzle[k] then begin 
place k; 
goto 1; 
end; 

wr iteln(*PuzzIe filled.*); 
place :* 0; 

1: 

end; 

procedure remove (i : pieceType; j : position); 

var k : position; 

begin 

for k := 0 to pieceMax[i] do 

if p[i,k] then puzzle[j+k] := false; 
pieceCount[class[i]] :* pieceCount[class[i]] + 1; 
end; 


function trial (j : position) : boolean; 

label 1; 

var 

1 : pieceType; 
k : position; 
begin 

for i ;« 0 to typeMax do 
if pieceCount[cIass[i]] <> 0 then 
If fit (i, j) then begin 
k ;= pI ace ( I, j); 
if trial(k) or (k = 0) then begin 
wr iteIn(*Piece *,I + 1,*at *,k+1); 
trial := true; 
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goto 1; 

end eIse remove ( i, j); 
end; 

trial := false; 

1 :kount := kount + 1; 

end; 

beg i n 

wr I teIn('BegInning PUZZLE*); 
for m := 0 to size do puzzle[m] true; 

for i :* 1 to 5 do for j :* 1 to 5 do for k ;■ 1 to 5 do 

puzzIe[i+d*(j+d*k)] := false; 

for i := 0 to typeMax do for m :* 0 to size do p[i,m] := false; 

for i := 0 to 3 do for j :■ 0 to 1 do for k := 0 to 0 do 

p[0,i+d*(j+d*k)] := true; 

class[0] := 0; 
pieceMax[0] := 3+d*1+d*d*0; 

for i := 0 to 1 do for j := 0 to 0 do for k :« 0 to 3 do 
p[1.I+d*(j+d*k)] :» true; 

cIass[ 1 ] :*= 0; 
pieceMax[1] := 1+d*0+d*d*3; 

for i := 0 to 0 do for j := 0 to 3 do for k := 0 to 1 do 
p[2,i+d*(j+d*k)] := true; 

class[2] 0; 
pieceMax[2] := 0+d*3+d*d*1; 

for i ;= 0 to 1 do for j :» 0 to 3 do for k := 0 to 0 do 
p[3,i+d*(j+d*k)] := true; 

class[3] := 0; 
pieceMax[3] :*= 1+d*3+d*d*0; 

for i 0 to 3 do for j :■ 0 to 0 do for k ;*= 0 to 1 do 
p[4,i+d*(j+d*k)] :* true; 

class[4] := 0; 
pieceMax[4] : = 3+d*0+d*d*1; 

for I :« 0 to 0 do for j :■ 0 to 1 do for k :» 0 to 3 do 
p[5,l+d*(j+d*k)] ;« true; 

cIass[5] :*= 0; 
pieceMax[5] 0+d*1+d*d*3; 

for I :« 0 to 2 do for j ;■ 0 to 0 do for k :■ 0 to 0 do 
p[6,i+d*(j+d*k)] :■ true; 

class[6] :« 1; 
pieceMax[6] :* 2+d*0+d*d*0; 

for I :■ 0 to 0 do for j :■ 0 to 2 do for k :* 0 to 0 do 
p[7,I+d*(j+d*k)] ;« true; 

class[7] :* 1; 
pieceMax[7] :■ 0+d*2+d*d*0; 

for i :* 0 to 0 do for j ;■ 0 to 0 do for k :■ 0 to 2 do 
p[8,i+d*(j+d*k)] :« true; 

class[8] :* 1; 
pieceMax[8] :■ 0+d*«0+d*d*2; 

for i :■= 0 to 1 do for j ;■ 0 to 1 do for k :■ 0 to 0 do 
p[9,i+d*(j+d*k)] :■ true; 

class[9] := 2; 
pieceMax[9] := 1+d*1+d*d*0; 

for i :* 0 to 1 do for j :■ 0 to 0 do for k :* 0 to 1 do 
p[10.i+d*(j+d*k)] :■ true; 

c I ass[101 :■ 2; 
pieceMax[10] :■ 1+d*0+d*d*1; 

for 1 ;« 0 to 0 do for j :■ 0 to 1 do for k :* 0 to 1 do 
p[11.i+d*(j+d*k)] := true; 

closs[11] 2; 

pieceMax[11] :■ 0+d*1+d*d*1; 

for I :« 0 to 1 do for J :■ 0 to 1 do for k :« 0 to 1 do 
p[12,i+d*(J+d*k)] :* true; 


(continued) 
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class[12] :* 3; 
pieceMax[l2] 


pieceCount [0 
pieceCount 11 
pieceCount \2 
pleceCount L3_ 
m :* 1 +d*( 1 +d* 1 ); 
kount 0 ; 


« 1 +d* 1 +d*d* 1 ; 
- 13; 

“ 3; 

- 1 ; 

- 1 ; 


If fIt( 0 ,m) then n :■ place( 0 ,m) else wrIteln('Error.*); 
If trlal(n) then wrIteIn(’Success In ’,kount,' trials.’) 
else wrIteln(’Fallure. ' ) ; 
end. 


badfI Ie. c 
TEXT 

Programming Insight: "Badfile: CP/M System Programming In C," Louis Baker. 
February, page 157. 


/* program to identify which file reside on "bad" track&sector */ 
/* Copyright 1985 Louis Baker all rights reserved */ 

#include "libc.h" 

#define ESC 27 
#define CR 13 
#define LF 10 

#define FF 255 /* code returned by find bdos call if no file */ 
^define DFCB 92 /* 92 =« 5CH address of default file control blk */ 
^define DMA 128 /* address of DMA */ 

struct dpb } 

char spt[ 2 ];/* low order byte first */ 
char bsh; 

int blmexm,dsm,drm,al,cks; /*not used */ 
char off[ 2 ]; 

} /* disk parameter block structure */ ; 

struct fcbj 

char drive; 
char fname[ 8 ]; 
char type[3]; 
char fex; 
char sys[ 2 ]; 
char free; 
char falg[l 6 ]; 
char cr; 
char r 0 ,r 1 ,r 2 ; 

\ /* file control block */; 


main (argc.argv) /* IDENTIFY FILE CORRESP. TO BAD SECTOR */ 
int arge; 

register Int i; 

static int mode,a Ig,track,sector,seept,offset,bIs,Iength,j; 
static int bad,bIksf,driven,bc,de; 
int *hI ; 

struct feb *fcbp,*fcb2; 
struct dpb *dpbp; 
char name[13],byte; 

/* CPM version number */ 

bc=12; de=0 /* unused */; j « bdos(bc,de) ;/* this works */ 
printf(" CP/M version number %x\n",j); 

/* desired drive? */ 

printf("enter drive (defauIt=0,A=1,B=2,etc) "); 
scanf(" %d",&driven) /* scanf need pointers */; 

/♦input desired mode of search */ 
printf("enter 0 if track/sector given, 1 if group"); 
scanf(" %d",&mode); 

/* BIOS CALL to select disk if not default */ 
bc=driven-1;/* be registers for disk selection */ 

/* SELDSK 9th bios entry hi points to disk parameter 
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header */ 

if(be!=-1) hi = bioshI(9,bc.de); 
printf(" alloc, group of disk parameter header %x\n",hl); 
if(mode=* 1 ) { /* read in allocation group */ 
printf(" enter hex alloc, gp."); 
scanf("%x",&aIg); 

/* use hi* adr of disk parameter header to get dp block */ 
hi * hi +5; /* 5 words » 10 bytes */ 

/* hi now points to dpb address */ 
printf(" address containing dpb address %x\n",hl); 
dpbp= *hl; /* dpbp* contents of what hi points to */ 
printf(" loc of dpb %x\n",dpbp); 

/♦dpbp points to address in dpb field of dph */ 

else } v v 

pr intf (" enter track(decima !)")*» 
scant(" %d",&track); 
printf(" enter sector (decimal)"); 
scant(" %d",&sector); 

/* determine allocation group */ 

/* another way to locate dp block-BDOS CALL */ 
be * 31; 

dpbp * bdoshI(bc,de) ;/* get dpb address, de unused */ 

/* now find allocation group */ 

seept * (dpbp->spt[0]) +256 * (dpbp->spt[1]) ; 

printf(" sectors per track %d\n", seept); 

offset* (dpbp->off[0])+256*(dpbp->off[1]); 

printf(" offset %d\n".offset); 

blksf * dpbp->bsh; 

/* prIntf(" loc offset %x\n",&(dpbp->off)); */ 

printf(" block shift factor %d\n",bIksf); 
a I g * 

( (track-offset)*secpt +sector -1 ) »(blksf); 

| /* END of else clause */ 
check */ 

alloc.gp.- %x\n", alg); /* code working 
/* now search for that alloc, gp. */ ; 

DFCB /* specify file control block 

fcbp->drive* driven /* drive name */; 

/* set file name,type.extent to wild card 
for (i* 0 ;i< 8 ;i++) 

fcbp->fname[i]* *?’; 

fcbp->type[ 0 ]= *?* ;fcbp->type[ 1 ]=’?*;fcbp->type[ 2 ]=*?*; 
fcbp->fex* •?• /* we don't use strings, which require \0 
term. */ ; 

/* loop over files max 64 dir. entries in CP/M*/ 
length * dpbp->drm; 

printf(" directory length %d entries\n",Iength); 
for (bc*17,j=0; j<length;J++,bc*18) { 
mode * bdos(bc,fcbp); 

/* DE*fcbp points to fcb. A*directory code 

mode *FF if done else 0 to 3 */ 


/* echo 
pr Int f ( 

f cbp 


up to here */ 
*/; 

? */ 


in variabIe 
if (mode**FF) 

goto fini; 

fcb2 * mode*32 + DMA ;/* point to found fcb */ 
/* loop over groups in this extent */ 
for(i*0;I<16;i++)| 

if(fcb 2 ->falg[i]*=alg) 
goto found; 

/* we could put here go 
if (fcb 2 ->fa Ig[i]*«’\ 0 ’) break; 

} /* end of the for loop over extent*/ 

\ /* end of for loop over directory entries */ 
fini: prIntf(" no user file at that group\n"); 

goto term; 

found;/* print file name, get size and approx, 
j-fcb 2 ->fex; 

pr Intf(" bad record %d of extent %d\n'\ i + 1 ,j); 

/* BDOS call for record count */ 

bc*35; 

fcb 2 ->drive * fcbp->drIve;/* move drive i.d. to 

make fcb out of file Info In DMA area */ 

hi » bdoshI(be,fcb2); /* CP/M to get record count*/ 

/* call to bdos or CPM equivalent, as answer in fcb */ 
if ( (fcb2->r2) -- 1 ) length - 65536; 


to next file if falg=0 */ 


position */ 


[continued) 
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else length- ((Int)(fcb2->r0)) + 256*((Int)(fcb2->r1)); 
prlntf(" bod file: %d records\n",Iength); 

/* position of bod sector NB- 1 record can be >1 sector In file */ 

Iength-(100*(16*j+I))/length; 

prlntff" bad record approx %d percent Into fI Ie:\n",Iength); 
pfIIen(fcb 2 ); 

term: exit( 0 );/*return to system, job done */ 

i 


pfilen(fcbp) struct fcb *fcbp; 

{ 

struct fcb *fcb2; 

static char pname[9],ptype[4]; 

regIster int I; 

fcb2«fcbp; 

pname[8]»’\0’;ptype[3]«’\0*; 

/* move i no longer needed for position of bad gp. */ 
for (1-0;l<8;I++) pname[i]- fcb2->fname[i]; 
for (i-0;I<3;!++) ptypefi]- fcb2->type[i]; 

/* terminate string name-eIiminate trailing blanks in name */ 
for (1*7;!>-1;1—)J 

I f (pname[ IJ—* * )pname[ I ]-*\0*; 

else break; /* do NOT eliminate embedded blanks */ 

\ 

/* output file ID */ 

printf ("%s.%s\n",pname.ptype); 

I 


Ievien.Ibr 
BINARY 

"Visual Programming," Ralph Levien, 

February, page 135. Download lu.exe to unpack this library. 


The following files accompany the article, "Visual Programming", by Raph 

Levien, which appeared in the Feb. 1986 issue of BYTE, page 135: 

SMALLVSD - This version of the visual syntax editor requires an IBM PC 

and BYSO LISP, an implementation of LISP available from Levien 
Instrument Company, POBox 31, McDowell, VA 24459. 

XLISPVSD - This version of the visual syntax editor requires an IBM PC 
and version 1.5d (or later) of XLISP, a public domain 
implementation of LISP that is available free of charge 
from BYTEnet Listings and the BYTE Information Exchange (BIX). 

XLISP15D.EXE - This Is an executable version of XLISP, with special 

modifications that allow it to run XLISPVSD, a version 
of the visual syntax editor. XLISP and the XLISP version 
of the visual syntax editor were written by David Betz. 
(Note that the article incorrectly identifies this version 
of XLISP as 1.5c.) 

FIB - This is the source code for the Fibonacci function described 

in the article "Visual Programming", and may be used with 
either the BYSO LISP or XLISP versions of the visual syntax 
editor. 

GRINDEF - This is the source code for the grindef function described 
in the article "Visual Programming." XLISP does not include 
this function, so you must load it (as described below) before 
you can use it in XLISP. 


XLISP15.EXE 

Using the Visual Syntax Editor with XLISP 1.5d 

To use the visual syntax editor with XLISP 1.5d, enter XLISP by typing 
XLISP15D 

at the MS-DOS prompt. The program will respond 
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XLISP version 1.5d, Copyright (c) 1985, by David Betz 
> 

To load the visual syntax editor, type 

(load "XLISPVSD") 

and the program wiI I respond 

; loading "XLISPVSD” 

T 

From there, you can follow the examples as given in the article, "Visual 
Programming," except that to load the Fibonacci function, you type 

(load "fib") 

and to load the grindef function (described on page 138) you type 
(load "grindef") 

Note: there is a typographical error in the article, and the syntax for 
using grindef to view the definition of a function in the visual editor is 

(edv (grindef ’function-name)) 

Further information on XLISP is available in the March 1984 BYTE article, "An 
XLISP Tutorial," by David Betz, page 221. 


GRINDEF 

; (grindef sym) return the function definition associated with a symbol 
(defun grindef (sym) 

(if (and (symbolp sym) 

(boundp sym) 

(consp (symbol-value sym)) 

(consp (car (symbol-value sym))) 

(consp (cdar (symbol-value sym)))) 

‘(defun ,sym ,(cadar (symbol-value sym)) ,@(cddar (symbol-value sym))))) 
(defun cadar (x) 

(cadr (car x))) 

(defun cddar (x) 

(cddr (car x))) 

FIB 

0 efun fib (x) (if (< x 2) 1 (+ (fib (- x 1)) 

(fib (- x 2))))) 

SMALLVSD 

"BYSO Visual Syntax Editor-Limited Version" 

"Copyright (C) 1985 Raphael L. Levien" 

"For private, non-commercial use only." 

(putprop ‘defun *vsd ‘defund) 

(putprop ‘quote *vsd ’quoted) 

(defsetf in ins) 

(defun vsd (I) 

(let ((he (gensym))) 

(els) 

(vsdl (grindef I) 

160) 

(setc 3360))) 

(defun vsdl (I p) 

(if (eq he I) 

(highlt I p) 

(if (consp I) 

(if (get (car I) 

‘vsd) 

(funcaI I (get (car I ) 

‘vsd) 

I 

P) 

(adj (car I) 

P 
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(vsd4 (cdr I) 

(vsd3 (car I) 

(vsd2^p)))) 

(defun ved2 (I p) 

(let* ((8 (expand I)) 

(si (length s))) 

(progl (setc (- p (+ si si))) 
(pstrlng s)))} 

(defun vsd3 (a p) 

(let* ((s (expand a)) 

(si (length s)) 

(b (- p (+ si si 4)))) 

(setc b) 

(tyo 218) 

(for i 1 si 1 (tyo 196)) 

(tyo 191) 

(setc (plus 160 b)) 

(tyo 179) 

(pstrlng s) 

i tyo 195) 
setc (+ b 320)) 
tyo 192) 

for I 1 si 1 (tyo 196)) 

(tyo 217) 

b)) 

(defun adj (a p h) 

(let* ((s (expand a)) 

(si (length s)) 

(b (- p (+ si si -316))) 

(ds (array 'char (+ si 2)))) 

(aset 179 ds 0) 

(aset 179 ds (+ 1 si)) 

(for I 1 si 1 (aset 32 ds I)) 

(setc (for I b (- (max b (car h)) 
160) 

160 

(setc I) 

(pstrlng ds))) 

(tyo 192) 

(for I 1 si 1 (tyo 196)) 

(tyo 217) 

(max b (- (cdr h) 

160 )))) 

(defun vsd4 (a p) 

(do ((I a (cdr I)) 

(c p)) 


((null I) 

(cons (+ c 160) 

, p)) , 

(setc (setq 


c (+ p 


(if (consp (car 
156 

-4)))) 


(tyo 196) 

(tyo 26) 

(setq p (+ (* 160 (/ (vsdl (car I) 

(- P 4)) 

1 60 ) ) 

(remainder p 160) 

160)))) 

(defun defund (I p) 

(setc 0) 

(msg "Function: " (cadr I) 
t 

"VariabIes:") 

(if (and (caddr I) 

(atom (caddr I))) 

(setq I (cdr I))) 

(do ((tl (caddr I) 

(cdr tl))) 

((null tl)) 

(msg " " (car t!))) 

(vsdl (if (cddddr I) 

i cons ’proan (cdddr I)) 
cadddr I)) 
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(defun quoted (I p) 
(vsd2 (cadr I) 

(+ 160 p))) 

(defun highlt (I p) 

(let ((II (+ (getc 1) 

0 )) 

(he (gensym))) 
(prog2 (setc (getc 2) 
1 ) 

(vsdl I p) 


(setc II 1)))) 
(defun In (x y) 

(if (nuI I y) 


x 

(nth (car y) 

(in x (cdr y))))) 

(defun ins (z y v) 

(if (nuI I y) 

(setq x v) 

(setf (nth (car y) 

(in z (cdr y))) 

v))) 

(defun edv (x) 

(prog (curs com) 

(setq x (subst nil nil x) 
curs 

(if (and (consp x) 

(eq (car x) 

'defun)) 

(list (if (and (caddr x) 

(atom (caddr x))) 

4 


nil)) 

(els) 


3 )) 


i setq cont x) 
dhlt x) 

seta com (tyk)) 
if (- (low com) 


27) 

(stoped)) 

(if (» (high com) 

72) 

(setf (car curs) 

(- (car curs) 

D)) 

(if (« (high com) 

75) 

(setq curs (cons 1 curs))) 
(if (■ (high com) 

77) 

(setq curs (cdr curs))) 

(if (« (high com) 

80) 

(setf (car curs) 

(+ (car curs) 

D)) 

(If (■ (low com) 

99 ) 

(cheI)) 

(if (- (low com) 

97) 

(addarg)) 

(if (■ (low com) 


105) 

(Inal)) 

(if (- (low com) 

100 ) 

(delei)) 

(If (* (low com) 
116) 


(continued) 
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(testel)) 

(go a))) 

(defun tyk expr nil (setc (gate)) 

(car ((bios 22) 

, 0))) , V 

(defun dhlt (I) 

(let ((he (In I curs))) 

(vsdl I 160) 

(setc 3360))) 

(defun chel expr nil (msg "Change to") 

(setf (In x curs) 

(readel "Change to: ")) 

.(cls)) 

(defun readel (m) 

(msg " a)tom or f)unctlon? ") 

(If (» (low (tyk)) 

102 ) 

(progn (msg "function" t m) 

(list (read))) 

(progn (msg "atom" t m) 

, (read)))) 

(defun addarg expr nil (msg "Add argument") 

(setf (edr (lastcdr (In x curs))) 

(list (readel "Argument: "))) 

(cls)) 

(defun lastcdr (x) 

(cond ((nuI 1 x) 
nil) 

((nu11 (edr x)) 

x) 

(t (lastcdr (edr x))))) 

(defun inel expr nil (when curs (msg "Insert") 

(setf (nthedr (car curs) 

(In x (edr curs))) 

(cons (readel "Insert: ") 

(nthedr (car curs) 

(in x (edr curs))))) 

(cls))) 

(defun delel expr nil (when curs (setf (nthedr (car curs} 

(In x (edr curs))) 
(nthedr (+ (car curs) 

1 ) 

(in x (edr curs)))) 

(If (not (nthedr (car curs) 

(in x (edr curs)))) 

(if (« (car curs) 

, 1 ) 

(setq curs (edr curs)) 


(defun testexp 
(prog (val) 

(setq val (eval 
(msg "Value: ") 
(print val) 

(msg "Press any 




(setf (car curs) 
(- (car curs) 
1 )))) 

, v (cls))) 

(exp) 

exp)) 

key to return to editor: 


)) 


") 


(defun testel expr nil (If curs (progn (msg "w)hole display or highlighted area? 

(if (= (low (tyk)) 

104) 

(progn (msg "highlighted area" t) 

(testexp (In x curs))) 

(progn (msg "whole display" t) 

(testexp x)))) 

(testexp x))) 

(defun stoped expr nil (msg "Are you sure you want to exit the editor? ") 

(If (* (low (tyk)) 

121 ) 

(progn (terprl) 

(return x)) 

(cls))) 

(defun ask (m) 
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(msg m) 
(read)) 


XLISPVSD 

; BYSO Visual Syntax Editor-Limited Version 
; Copyright (C) 1985 Raphael L. Levien 
; ALL RIGHTS RESERVED 

; Converted for XLISP version 1.5c on the 
IBM-PC by David Betz 

(putprop 'defun 'defund 'vsd) 

(putprop 'quote 'quoted 'vsd) 

(setq *he* nil) 

(defun vsd (I) 

(let ((old-he *he*)) 

(cI ear) 

(setq *he* (gensym)) 

(vsdl I 160) 

(setq *he* old-he) 

(setc 3360))) 


(defun vsd3 (a p) 

(let* ((si (fI ate a)) 

(b (- p (+ si si 4)))) 

(setc b) 

(write-char 218) 

(dotimes (i si) (write-char 196)) 
(write-char 191) 

(setc (+ 160 b)) 

(write-char 179) 

(prlnc a) 

(write-char 195) 

(setc (+ b 320)) 

(write-char 192) 

(dotimes (1 si) (write-char 196)) 

(write-char 217) 

b)) 

(defun adj (a p h) 

(let* ((81 (flate a)) 

(b (- p (+ si si -316))) 

(top (- (max b (car h)) 160))) 
(setc (do ((i b (+ i 160))) 

((> I top) I) 

(setc i) 

(write-char 179) 

(dotimes (i si) (write-char 32)) 
(write-char 179))) 

(write-char 192) 

(dotimes (i si) (write-char 196)) 
(write-char 217) 

(max b (- (edr h) 160)))) 

(defun vsd4 (a p) 

(do ((I a (edr I)) 

(c p)) 


(defun vsdl (I p) 

(If (eq *he* I) 

(hlghlt I p) 

(If (consp I) 

(if (and (symbolp (car I)) (get (car I) 'vsd)) 
(funcall (get (car I) 'vsd) I p) 

(adj 
(car I) 

P 

(vsd4 (edr I) (vsd3 (car I) p)))) 

(vsd2 I p)))) 

(defun vsd2 (I p) 

(progl 

(setc (- p (* (flatc I) 2))) 

(princ I))) 


{continued) 
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((null I) 

(cons (+ c 160) 

P)) 

(setc (setq c (+ p (If (consp (car I)) 
156 

-4)))) 

(write-char 196) 

(write-char 26) 

(setq p (+ (* 160 (/ (vsdl (car I) 

(- P 4)) 

160)) 

(rem p 160) 

160)))) 

(defun defund (I p) 

(setc 0) 

(msg "Function: " (cadr I) 
t 

"Variables:") 

( l f (and (nth 2 I) 

(atom (nth 2 I))) 

(setq I (cdr I))) 

(do ((tl (nth 2 I) 

(cdr tl))) 

((null tl)) 

(msg " " (car tl))) 

(vsdl (If (nthcdr 4 I) 

(cons ’progn (nthcdr 3 I)) 

(nth 3 I)) 

P)) 

(defun quoted (I p) 

(vsd2 (cadr I) 

(+ 160 p))) 

(defun highlt (I p) 

(let ((old-he *he*)) 

(let (r) 


(set-inverse t) 

(setq *he* (gensym)) 

(setq r (vsdl I p)) 

(setq *he* old-he) 

(set-inverse nil) 

r))) 

(defun In (x y) 

(if (nulI y) 
x 

(nth (car y) 

(in x (cdr y))))) 

(defun ins (z y v) 

(If (nuI I y) 

(setq *x* v) 

(setf (nth (car y) 

(in z (cdr y))) 

v))) 

(defun edv (x) 

(prog (com) 

(setq *x* (subst nil nil x) 

♦curs* 

(if (and (consp *x*) 

(eq (car *x*) 

* defun)) 

(list (if (and (n:~ 2 *x*) 

(etc- (nth 2 *x*))) 

4 

3 )) 

nil)) 

(clear) 

a 

(dhlt *x*) 

(setq com (get-key)) 

(if (= com 27) ; esccre 

(stoped)) 

(if (= com 200) ; 


128 BYTE LISTINGS SUPPLEMENT 









(if *curs* (setf (car *curs*) 

(1- (car *curs*))))) 

(progn 

(msg "atom" t m) 

(if (« com 203) ; left 

(read)))) 

(setq *curs* (cons 1 *curs*))) 


(if (= com 205) ; right 

(defun addarg () 

(setq *curs* (cdr *curs*))) 

(msg "Add argument") 

(if (* com 208) ; down 

(setf (cdr (last (in *x* *curs*))) 

(if *curs* (setf (car *curs*) 

(1+ (car *curs*))))) 

(list (readel "Argument: "))) 

(if (« com 99) ; (c)hange 

(c1 ear)) 

(chel)) 

(if (« com 97) ; (a)dd 

(defun inel () 

(addarg)) 

(when *curs* 

(if (« com 105) ; (i)nsert 

(msg "Insert") 

(inel)) 

(setf (cdr (nthcdr (1- (car *curs*)) 

(if (« com 100) ; (d)elete 

(in *x* (cdr *curs*)))) 

(delei)) 

(cons (readel "Insert: ") 

(if (« com 116) ; (t)est 

(nthcdr (car *curs*) 

(teste 1)) 

(in *x* (cdr *curs*))))) 

(go a))) 

(clear))) 

(defun dhlt (1) 

(defun delel () 

(let ((old-he *he*)) 

(setq ♦he* (in 1 *curs*)) 

(when *curs* 

(setf (cdr (nthcdr (1- (car *curs*)) 

(vsdl 1 160) 

(in *x* (cdr *curs*)))) 

(setq *he* old-he) 

(nthcdr (1+ (car *curs*)) 

(setc 3360))) 

(in *x* (cdr *curs*)))) 

(defun chel () 

(if (not (nthcdr (car *curs*) 

(in *x* (cdr *curs*)))) 

(msg "Change to") 

(ins *x* *curs* (readel "Change to: ")) 

(if (= (car *curs*) 1) 

(clear)) 

(setq *curs* (cdr *curs*)) 

(setf (car *curs*) (1- (car *curs*))))) 

(defun readel (m) 

(msg " a)tom or f)unction? ") 

(clear))) 

(if (« (get-key) 102) 

(defun testexp (exp) 

(progn 

(prog (val) 

(msg "function" t m) 

(setq val (eval exp)) 

(list (read))) 

(msg "Value: ") 

{continued) 
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(print val ) 

(msg "Press any key to return to editor: ") 
(get-key) 

(clear))) 

(defun testel () 

(If *curs* 

(progn 

(msg "w)ho I e display or highlighted area? ") 
(If (» (get-key) 104) 

(progn 

(msg "highlighted area" t) 

(testexp (in *x* *curs*))) 

(progn 

(msg "whole display" t) 

(testexp *x*)))) 

(testexp *x*))) 

(defun stoped () 

(msg "Are you sure you want to exit 
the editor? ") 

(if (« (get-key) 121) 


(progn 
(terpr1) 

(return *x*)) 

(clear))) 

(defun ask (m) 

(msg m) 

(read)) 

; functions required for XLIS? 

(defun setc (p) 

(set-cursor (/ p 160) (rtr (j : : 36)) 

P) 

(defun msg (&rest args) 

(mapcar #’(lambda (x) (if (<*: ■ *. terpri) 
(princ x))) args)) 

(expand 1) 


far re I I.Ibr 
BINARY 

Programming Insight: "Molecules in Color," John J. Farrell. 

February, page 149. Download lu.exe to unpack. For a TEXT file version, 
down load farreI I.Iib. 


The following programs accompany the article "Molecules in Color", which 
describes C0L0R3D.BAS, a color IBM PC version of M0DEL3D.BAS, a Macintosh 
program that appeared in the February 1985 BYTE. 

C0L0R3D.BAS - the program, which requires an IBM PC or compatible, and 
BASICA 

The following are data files to be used with C0L0R3D.BAS: 

B5H9.DAT 

B10H14.DAT 

C7H702N.DAT 

NACL.DAT 

CR(C6H6).DAT 

CRDIBENZ.DAT 

BENZENE.DAT 

PATTERNS.DAT - This data file generates the patterns that you may use wit* 
C0L0R3D.BAS 
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farreI I.Iib 
TEXT 

Programming Insight: "Molecules in Color," John J. Farrell. 
February, page 149. All the programs in one file. 


1000 ' ********* COLOR3D.BAS ********* 

1010 ’ Draws a 3D, perspective image of o molecule on IBM PCs with BASICA. 
1020 ’ For private, noncommercial use only. 

1030 * John J. Farrell *** April 1, 1985 

1040 ’ Inspired by Earl Kirkland’s M0DEL3D.BAS for the Mac, BYTE, Feb. 1985. 
1050 SCREEN 1 'medium resolution; color 

1060 COLOR 0,1 'background = black(0); cyan(1); magenta(2); white(3) 

1070 KEY OFF 

1080 DEFINT I-N: DEFSNG 0-Z: DEFSNG A-G 

1090 DIM X(200), Y(200), Z(200), S(200), COL(200),COLPAT(200),TIL$(200) 

1100 ' 

1110 ' Ask for input parameters. 

1120 CLS: INPUT "Data file nome:", FILE$ 

1130 INPUT "Azim., polar angles (phi, theta):", PHI, THETA 
1140 INPUT "Viewing distance:".VIEWD 
1150 INPUT "Size magnitude:“,SMAG 
1160 SMAG = 1.15*SMAG 

1170 ’ DISTORT is used later to account for fact that one unit of x 
1180 ’ on screen (horizonal) is not equal to one unit of z (vertical). 

1190 DISTORT =1.2 

1200 ’ Convert degrees to radians. 

1210 PHI = PHI*3.14159/180!: THETA = THETA*3.14159/180! 

1220 CP = COS(PHI): SP = SIN(PHI): CT = COS(THETA): ST = SIN(THETA) 

1230 ' 

1240 OPEN FILE$ FOR INPUT AS #1 

1250 ' Set xmin very large and xmax very small. 

1260 XMIN = 1000000!: XMAX = -XMIN: YMIN = XMIN: YMAX = XMAX 
1270 ZMIN = XMIN: ZMAX = XMAX: N = 0 

1280 ' Read data file: color, x.y.z (atomic coords),r (Angstroms). 

1290 WHILE NOT E0F(1) 

1300 N = N + 1 

1310 INPUT #1.COLPAT(N), X(N),Y(N), Z(N), S(N) 

1320 IF COLPAT(N)<= 3 THEN COL(N) = COLPAT(N): TIL$(N) = CHR$(4HAA) 

1330 IF COLPAT(N) = 4 THEN COL(N) = 1: TIL$(N) =CHR$(4H66) + CHR$(4H99) 

1340 IF COLPAT(N) = 5 THEN COL(N) = 3: TIL$(N) = CHR$(4HAF) +CHR$(&HAF) + 

CHR$(4HFA) + CHR$(4HFA) 

1350 IF COLPAT(N) = 6 THEN COL(N) = 2: TIL$(N) =CHR$(4H55) + CHR$(4HFF) 

1360 IF COLPAT(N) = 7 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4H69) + 

CHR$(4HFF) + CHR$(4H5A) + CHR$(4HA5) + CHR$(4HFF) + CHR$(4H96) + CHR$(4HAA) 
1370 IF COLPAT(N) = 8 THEN COL(N) = 3: TIL$(N) = CHR$(4H5A) + CHR$(4H5A) + 
CHR$(4HA5) + CHR$(4HA5) 

1380 IF COLPAT(N) = 9 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4HAA) + 
CHR$(4H55) + CHR$(4H55) 

1390 IF COLPAT(N) = 10 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4HFF) 

1400 IF COLPAT(N) = 11 THEN COL(N) = 3: TIL$(N) = CHR$(4H5F) + CHR$(4H5F) + 

CHR$(4HF5) + CHR$(4HF5) 

1410 IF COLPAT(N) = 12 THEN COL(N) = 3: TIL$(N) = CHR$(4H69) + CHR$(4HAA) + 
CHR$(4HAA) + CHR$(4H96) 

1420 IF COLPAT(N) = 13 THEN COL(N) = 3: TIL$(N) = CHR$(4HBB) 

1430 IF COLPAT(N) = 14 THEN COL(N) = 3: TIL$(N) = CHR$(4HAB) 

1440 IF COLPAT(N) = 15 THEN COL(N) = 3: TIL$(N) = CHR$(4H57) 

1450 IF COLPAT(N) = 16 THEN COL(N) = 3: TIL$(N) = CHR$(4HAB) + CHR$(4HAB) + 

CHR$(4HFF) + CHR$(4HFF) 

1460 IF COLPAT(N) = 17 THEN COL(N) = 3: TIL$(N) = CHR$(4H57) + CHR$(4H57) + 
CHR$(4HFF) + CHR$(4HFF) 

1470 IF COLPAT(N) = 18 THEN COL(N) = 3: TIL$(N) = CHR$(4HFE) + CHR$(4HFA) + 
CHR$(4HFA) + CHR$(4HEA) + CHR$(4HFA) + CHR$(4HFE) 

1480 IF COLPAT(N) = 19 THEN COL(N) = 3: TIL$(N) = CHR$(4HEB) + CHR$(4HAA) + 
CHR$(4HAA) + CHR$(4HEB) 

1490 IF COLPAT(N) = 20 THEN COL(N) = 3: TIL$(N) = CHR$(4H77) 

1500 IF COLPAT(N) = 21 THEN COL(N) = 3: TIL$(N) = CHR$(4H69) + CHR$(4HAA) + 

CHR$(4HAA) + CHR$(4H69) 

1510 IF COLPAT(N) = 22 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4HBE) + 
CHR$(4HBE) + CHR$(4HBE) + CHR$(4HBE) + CHR$(4HAA) 

1520 IF COLPAT(N) = 23 THEN COL(N) = 3: TIL$(N) * CHR$(4HE9) + CHR$(4H9E) 

1530 IF COLPAT(N) = 24 THEN COL(N) = 3: TIL$(N) = CHR$(4HE9) + CHR$(4HE9) 

1540 ’ Find maximum and minimum values for x,y,z. 


(continued) 
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1550 IF X(N) > XMAX THEN XMAX - X(N) 

1560 IF X(N) < XMIN THEN XMIN - X(N) 

1570 IF Y(N) > YMAX THEN YMAX - Y(N) 

1580 IF Y(N) < YMIN THEN YMIN - Y(N) 

1590 IF Z(N) > ZMAX THEN ZMAX - Z(N) 

1600 IF Z(N) < ZMIN THEN ZMIN - Z(N) 

1610 WEND 

1620 PRINT N "otoms" 

1630 PRINT "rotating..." 

1640 ’ Find center values for x,y,z. 

1650 XCEN = .5*(XMAX-fXMIN): YCEN - ,5*(YMIN + YMAX): ZCEN - .5*(ZMIN+ZMAX) 
1660 * Rotate molecule around its center. 

1670 FOR I = 1 TO N 

1680 XA = X(I) - XCEN: YA = Y(I) - YCEN 
1690 X(I) - CP*XA+SP*YA: Y(I) » -SP*XA+CP*YA 
1700 YA » Y(I): ZA - Z(I) - ZCEN 
1710 Y(I) = CT*YA+ST*ZA: Z(I) = -ST*YA+CT*ZA 

1715 IF VIEWD < Y(I) THEN CLS: PRINT "Viewing distance is within molecule 
Rerun with a larger viewing distonce.": GOTO 2100 
1720 NEXT I: PRINT "sorting..." 

1730 * 


1740 ' Sort by depth (shell sort). 
1750 IGAP - INT(CSNG(N)/2!) 

1760 WHILE IGAP >« 1 

1770 FOR I = IGAP +1 TO N 

1780 FOR J - I-IGAP TO 1 STEP -IGAP 

1790 JG « J + IGAP 

1800 IF Y(J) <- Y(JG) THEN GOTO 1850 


1810 SWAP 
1820 SWAP 


8 ):' 


INT(CSNG(IGAP)/2!) 


Z(I) * YA: S(I) = S(I)»YA 


X(JG): SWAP Y(J), Y(JG) 

. . Z(JG): SWAP S(J). S(JG) 

1830 SWAP COL(J), COL(JG): SWAP COLPAT(J), COLPAT(JG): SWAP TIL$(J),TIL$(JG 
1840 NEXT J ' ' v 

1850 NEXT I 
1860 IGAP 
1870 WEND 
1880 * 

1890 CLS 

1900 * Perspective projection and scale coordinates. 

1910 SCALE = -1000000!: SMAX = SCALE 
1920 FOR I - 1 TO N 

1930 YA - 1!/(VIEWD - Y(I)): X(I) - X(I) *YA: Z(I) = 

1940 IF SCALE < ABS(X(I)) THEN SCALE = ABS(X(I)) 

1950 IF SCALE < ABS(Z(I)) THEN SCALE - ABS(Z(I)) 

1960 IF SMAX <S(I) THEN SMAX = S(I) 

1970 NEXT I: SCALE - 75!/(SCALE + .5+SMAX+SMAG) 

1980 SCALEX = SCALE*DISTORT 
1990 ’ 

2000 FOR I = 1 TO N 

2010 * Find screen x (ix) and screen 2 (iz) and screen radius (ir). 

2020 ' Center of screen is x - 160 and 2 «* 100 

2030 IX = INTfxm*SCALEX+ 160 !): IZ - INT(Z(I)*SCALE + 100 !) 

2040 IR = INT(s(I)*SCALE*SMAG): IRZ - IR/DISTORT 
2050 COL = COL(I): COLPAT = COLPAT(I): TIL$ = TIL$(I) 

2060 GOSUB 2130 
2070 NEXT I 
2080 CLOSE#1 

2090 IF INKEY$ = "" THEN 2090 
2100 END 

2110 ’ Draw patterned circles at ix,i 2 with radius ir. 

2120 ’ Draw a circle in color. 

2130 CIRCLE (IX.IZ),IR+1.C0L 

2140 ’ Paint the circle black. Start in center and at four extremities 
2150 ’in an attempt to completely blacken the circle. 

2160 PAINT (IX.IZ) 0.COL: PAINT (IX-IR+1.IZ).0.COL: PAINT (IX+IR-1,IZ),0.CO. 
PAINT (IX,IZ-IRZ+1),0,COL: PAINT (IX,IZ+IRZ-1).0.COL 
2170 * Paint the circle in color. 

2 ]80 PAINT (IX.IZ),COL COL: PAINT (IX-IR+1.IZ).COL,COL: PAINT (IX+IR 

-1,IZ),COL,COL: PAINT (IX,IZ-IRZ+1),COL,COL: PAINT (IX,IZ+IRZ-1),COL,COL 

2190 ’ Draw circle with a new border color and paint black 

2200 IF COL » 1 THEN COLBOR = 3 

2210 IF COL = 2 THEN COLBOR - 3 

2220 IF COL = 3 THEN COLBOR - 1 

2230 CIRCLE (IX,IZ).IR+1.COLBOR 

2240 PAINT (IX,IZ),0,COLBOR 

2250 ’ Paint circle with final pattern. 

2260 IF COLPAT <=3 THEN PAINT (IX, IZ) .COL .COLBOR ELSE PAINT 
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(IX,IZ),TIL$,COLBOR 

2270 ’ Drow the circle in block ond point it block. 

2280 CIRCLE (IX,IZ),IR+1,0 

2290 PAINT (IX,IZ),0,0: PAINT (IX-IR+1,IZ),0,0: PAINT (IX+IR-1,IZ),0,0: PAINT 
(IX,IZ-IRZ+1),0,0: PAINT (IX,IZ+IRZ-1),0,0 

2300 ’ Drow the circle in color ond point with finol pattern. 

2310 CIRCLE (IX,IZ).IR+1.COLBOR 

2320 IF COLPAT <=3 THEN PAINT (IX.IZ),COL,COLBOR ELSE PAINT 

(IX,IZ),TIL$,COLBOR 

2330 * Draw the circle in black. 

2340 CIRCLE (IX,IZ),IR+1.0 
2350 RETURN 


b5h9.dat 


TEXT 


Programming Insight: "Molecules in Color," John J 

. Far re 11. 

February, page 149. This data file must be used with colored.bas 

5.0,0,1.08676,.83 

3,-2.34848,0,.49496,.37 

5,3.58,3.58,3.77676,.83 

3,1.23152.3.58,3.18496,.37 

3,0,0,2.29726,.37 

3,0,2.34848,.49496,.37 

3,3.58,3.58,4.98726..37 

3.3.58,5.92848.3.18496..37 

5,1.253,0,0,.83 

3,0,-2.34848,.49496,.37 

5,4.833.3.58,2.69,.83 

3,3.58.1.23152,3.18496,.37 

5,-1.253,0.0,.83 

3,.97376,.97376,-.8877001,.37 

5.2.327,3.58,2.69,.83 

3,4.55376,4.55376.1.8023,.37 

5,0,1.253,0,.83 

3,.97376,-.97376,-.8877001,.37 

5,3.58,4.833.2.69,.83 

3.4.55376.2.60624,1.8023,.37 

5.0.-1.253,0,.83 

3.-.97376,.97376,-.8877001..37 

5.3.58,2.327,2.69,.83 

3,2.60624,4.55376.1.8023,.37 

3,2.34848,0,.49496,.37 

3,-.97376,-.97376,-.8877001,.37 

3,5.92848,3.58.3.18496,,37 

3,2.60624,2.60624,1.8023,.37 

b10h14.dat 

5,.48858.6.9234,0.-88 

3.2.80215,6.12616.-1.2518,.38 

5.1.437,5.72754,.95592..88 

3,2.48601,3.44072,0,.38 

5,1.66692,5.83244.-.74539,.88 

3,.44547,3.65052,2.20772,.38 

5,1.39389,4.23796.0,.88 

3,.70413,6.69262.-1.35991..38 

5,.25866,4.42678.1.35991,.88 

3,1.22145.4.42678,-1.21766,.38 

5,-.48858,3.5666,0,.88 

3.-.58917,2.34976.0..38 

5,-1.437,4.76246,.95592,.88 

3.-2.35668,4.69952,1.8208,.38 

5,-1.66692,4.65756,-.74539..88 

3.-2.80215.4.36384.-1.2518,.38 

5,-1.39389,6.25204,0,.88 

3,-2.48601.7.04928,0,.38 

5,-.25866,6.06322,1.35991,.88 

3,-.44547,6.83948,2.20772,.38 

3,.58917,8.14024,0,.38 

3,-.70413,3.79738,-1.35991,.38 

3.2.35668,5.79048,1.8208,.38 

3,-1.22145,6.06322.-1.21766,.38 

patterns.dat 


TEXT 


Programming Insight: "Molecules in Color," John J. Farrell. 

February, page 149. This data file must be used with color3d.bas 


i.e,0,0,1 
2,3,0,0,1 
3,6,0,0,1 
4.9,0,0,1 
5.12.0.0,1 
6.15,0,0,1 
7.0.0,3.1 
8,3,0,3,1 


9.6,0,3,1 

10,9,0,3,1 

11.12.0.3,1 

12,15,0,3,1 

13,0,0,6.1 

14.3,0.6,1 

15,6,0,6,1 

{continued) 
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16,9.0,6,1 

17,12,0,6,1 

18,15,0,6,1 

19,0,0.9.1 

20.3,0,9,1 


21,6,0,9,1 

22.9.0,9,1 

23.12,0,9,1 

24,15,0,9,1 


c7h702n.dot 
TEXT 

Programming Insight: "Molecules In Color," John J. Farrell. 
February, page 149. This dota file must be used with color3d.bas 


4,6.612408.1.960494,-3.099765..778 
1.2.942464,1.054938,-1.322889,.699 

1.4.150042.. 732628,-.6921442,.699 
1,5.349948,1.056868,-1.255907,.699 
1,5.402778,1.690294,-2.49879,.699 
1,4.201226,2.029588,-3.136977..699 
1,2.998429.1.706892.-2.556469..699 

1.1.676018.. 648866,-.7330775,.699 

2.1.585782.. 034354..3349085..514 


2.. 5988608..9981959,-1.402595..5* 
3.-.1059083,.5211,-.9861195.-3J» 

3.4.142753.. 2509..2046663..5 78 

3.6.172514.. 91868,-.8186653,-37® 

3,7.395005,1.86824,-2.5861:: 5*3 

3,6.647874,2.61708,-3“ 

3,4.238428,2.57076,-4.?:': C : 

3,2.154166,1.8914,-3.032753 3*5 


cr(c6h6).dat 

TEXT 

Programming Insight: "Molecules in Color," John J. Farrell. 
February, page 149. This data file must be used with color3d.bas 


8,0,0,0.1.5 
8,0,4.835,4.835,1.5 
8,4.835,0,4.835,1.5 
8,4.835,4.835,0,1.5 

1.1.413754.1.599418, -.1934,.7 

1.-1.413754,-1.599418,.1934,.7 

1.6.248754.3.235582.. 1934..7 

1.3.421246.6.434418, -.1934,.7 

1.4.6416.3.421246, -1.599418,.7 
1,5.0284,6.248754,1.599418,.7 
1,6.434418,5.0284,-1.413754,.7 

1.3.235582.4.6416.1.413754.. 7 

1.1.599418, -.1934,1.413754,.7 

1,-1.599418,.1934,-1.413754..7 

1.3.235582.. 1934.6.248754..7 

1.6.434418, -.1934,3.421246,.7 

1.3.421246. -1.599418,4.6416..7 
1.6.248754,1.599418,5.0284,.7 
1,5.0284,-1.413754,6.434418,.7 

1.4.6416.1.413754.3.235582.. 7 
1.-.1934,1.413754,1.599418,.7 

1.. 1934,-1.413754,-1.599418,.7 

1.. 1934.6.248754.3.235582..7 

1.-.1934,3.421246,6.434418,.7 
1,-1.599418,4.6416,3.421246,.7 
1,1.599418.5.0284,6.248754,.7 
1,-1.413754,6.434418,5.0284..7 

1.1.413754.3.235582.4.6416.. 7 

1.. 476731..23208.2.065512..7 

1,-.476731,-.23208,-2.065512,.7 

1.5.311732.4.60292, -2.065512,.7 
1,4.358269,5.06708.2.065512..7 

1.6.900512.4.358269, -.23208,.7 

1.2.769488.5.311732.. 23208..7 
1.5.06708,2.769488,-.476731,.7 

1.4.60292.6.900512.. 476731..7 

1.. 23208.2.065512..476731..7 

1.-.23208,-2.065512,-.476731,.7 

1.4.60292, -2.065512,5.311732,.7 
1,5.06708.2.065512.4.358269,.7 

1.4.358269, -.23208,6.900512,.7 

1.5.311732.. 23208.2.769488..7 


1,2.769488,-.476731,5.05'?: * 

1.6.900512.. 476731.4.6: 

1.2.065512,.476731,.23205 ' 

1.-2.065512,-.476731,-.2::?:..' 
1,-2.065512,5.311732,4.6?;?: ' 

1.2.065512,4.358269,5.eS'?: * 

1,-.23208,6.900512,4.358:-:? 7 

1.. 23208.2.769488.5.3117:: ' 

1,-.476731,5.06708,2.769*:: ' 

1.. 476731.4.60292.6.90051: 

3.1.63423.2.2241, -1.10235 37 

3.-1.63423,-2.2241,1.102:: 3* 

3.6.46923,2.6109,1.10233 3* 

3.3.20077,7.0591,-1.1023: ,J7 

3.3.73262.3.20077, -2.224- 3* 

3,5.937381,6.46923,2.224-..I* 
3,7.0591.5.937381,-1.634;: 3* 

3,2.6109,3.73262.1.63423 3* 

3.2.2241, -1.10238,1.63423 .37 

3.-2.2241.1.10238,-1.634;: 3* 

3,2.6109,1.10238,6.46923 3' 

3,7.0591,-1.10238,3.200*' 3* 

3.3.20077, -2.2241,3.73262 ..ST 

3,6.46923,2.2241,5.93735- .3* 
3,5.937381,-1.63423,7.03?' 3* 

3,3.73262,1.63423,2.6105. 3* 
3,-1.10238,1.63423,2.224- .3' 

3,1.10238,-1.63423,-2.22- 1 - r~ 
3,1.10238,6.46923,2.6105 3* 

3,-1.10238,3.20077,7.05:-- 3' 

3.-2.2241,3.73262.3.200'* 3* 

3,2.2241,5.937381.6.465:3 3* 

3,-1.63423,7.0591,5.9373W.-» 
3.1.63423.2.6109.3.7325: J* 

3.. 13538,-.36746,2.92034..3* 
3,-.13538,.36746,-2.9203 *.S 
3,4.97038,5.20246,-2.:-:::- 
3,4.69962,4.467541 ,2.92834. 

3.7.75534.4.69962.. 36745 3' 

3,1.91466,4.97038,-.36746..3* 

3,4.467541,1.91466,-.1353: 3~ 
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3.5.20246.7.75534.. 13538..37 
3,-.36746,2.92034,.13538,.37 

3.. 36746,-2.92034,-.13538,.37 
3,5.20246,-2.92034,4.97038,.37 

3.4.467541.2.92034.4.69962.. 37 

3.4.69962.. 36746.7.75534..37 
3,4.97038,-.36746,1.91466,.37 
3,1.91466,-.13538,4.467541,.37 

3.7.75534.. 13538.5.20246..37 


3.2.92034.. 13538,-.36746,.37 
3,-2.92034,-.13538,.36746,.37 
3,-2.92034,4.97038,5.20246,.37 

3.2.92034.4.69962.4.467541.. 37 

3.. 36746.7.75534.4.69962..37 
3,-.36746,1.91466,4.97038,.37 
3,-.13538,4.467541,1.91466,.37 

3.. 13538.5.20246.7.75534..37 


benzene.dot 
TEXT 

Programming Insight: "Molecules in Color," John J. Farrell. 
February, page 149. This data file must be used with color3d.bas 


1,-.424474,1.340674,-.0364068,.699 

1.. 424474,-1.340674,.0364068,.699 
1,-.99591,.444636,.8521888,.699 

1, .99591,-.444636,-.8521888,.699 
1,-.577404,-.894105,.873089,.699 

1.. 577404..894105,-.873089,.699 


3,-.728096,2.36527,-.1193334,.378 

3,.728096,-2.36527,.1193334,.378 
3,-1.797114,.7674805,1.495376,.378 
3,1.797114,-.7674805,-1.495376,.378 
3,-1.022766,-1.576525,1.55875,.378 
3,1.022766,1.576525,-1.55875,.378 


crdibenz.dat 
TEXT 

Programming Insight: "Molecules in Color," John J. Farrell. 
February, page 149. This data file must be used with color3d.bas 


8 , 0 , 0 , 0 . 1.5 

1.1.413754.1.599418, -.1934,.7 

1,-1.413754,-1.599418,.1934,.7 

1.1.599418, -.1934,1.413754,.7 

1,-1.599418,.1934,-1.413754,.7 
1,-.1934,1.413754,1.599418,.7 
1, .1934,-1.413754,-1.599418,.7 

1.. 476731..23208.2.065512..7 

1,-.476731,-.23208,-2.065512,.7 

1.. 23208.2.065512..476731..7 

1,-.23208,-2.065512,-.476731,.7 
1,2.065512,.476731,.23208,.7 
1,-2.065512,-.476731,-.23208,.7 


3.1.63423.2.2241, -1.10238,.37 
3,-1.63423,-2.2241,1.10238,.37 

3.2.2241, -1.10238,1.63423,.37 
3,-2.2241, 1.10238,-1.63423,.37 
3,-1.10238,1.63423,2.2241,.37 
3,1.10238,-1.63423,-2.2241,.37 

3.. 13538,-.36746,2.92034,.37 
3,-.13538,.36746,-2.92034,.37 
3,-.36746,2.92034,.13538,.37 

3.. 36746,-2.92034,-.13538,.37 

3.2.92034.. 13538,-.36746,.37 
3,-2.92034,-.13538,.36746,.37 


nacI.dat 
TEXT 

Programming Insight: "Molecules in Color," John J. Farrell. 
February, page 149. This data file must be used with color3d.bas 


7,0,0,0,.95 
7,5.628,0,0,.95 
7,0,0,5.628,.95 
7,5.628,0,5.628,.95 

7.5.628.2.814.2.814.. 95 

7.2.814.2.814.5.628.. 95 
7,2.814,2.814,0,.95 
7,2.814,0,2.814,.95 
7,0,2.814,2.814,.95 
7,0.5.628,0,.95 
7,5.628,5.628,0,.95 
7,0,5.628,5.628,.95 

7.5.628.5.628.5.628.. 95 

7.2.814.5.628.2.814.. 95 


6.2.814.2.814.2.814.1.81 
6,2.814,0,0,1.81 
6,0,2.814,0,1.81 
6,0,0,2.814,1.81 
6,5.628,0,2.814,1.81 
6,2.814,0,5.628,1.81 
6,0,2.814,5.628,1.81 

6.5.628.2.814.5.628.1.81 
6,5.628,2.814,0,1.81 
6,0,5.628,2.814,1.81 
6,2.814,5.628,0.1.81 

6.2.814.5.628.5.628.1.81 

6.5.628.5.628.2.814.1.81 


{continued) 
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datagen.bas 


TEXT 

Programming Insight: 
February, page 149. 


"Molecules in Color." John J. Farrell. 


100 * Program to generate a data 
file for Cr(C6H6)(C0)3. 

105 ’ Page 5 of Vol 6 of Crystal 
Structures by Wyckoff. 

107 * Unit cell is monoclinic. 

110 INPUT “Output file name:"; 

FILE$ 

120 OPEN FILES FOR OUTPUT AS #1 
130 SIZ-1.4 : COL * 8 
140 A - 6.17 : B = 11.07 : C « 6.57 
: BETA - 101.5 

150 X = .3319 : Y=.25 : 2 « .0225 

160 GOSUB 1000 

200 SI2= .7 : COL * 1 


'ring carbons 


210 X = .1804 
220 GOSUB 2000 
230 X = .3761 
240 GOSUB 2000 
250 X = .5738 
260 GOSUB 2000 
270 SIZ- .64 
280 X = .5538 
290 GOSUB 1000 
300 X - .1827 
310 GOSUB 2000 
320 SIZ- .49: COL 


Y-.3119 : 2 —.2973 
Y-.3769 : 2 —.2273 


Y-.3142 : 

’carbonyl 
Y-.25 : 2 


-.1598 


carbons 

-+.2557 


Y-.3642 : 2 -+.1453 


’carbonyl oxygens 


*»Z 

Z —_22*c 


330 X « .6899 : Y=.25 : 

340 GOSUB 1000 
350 X = .0894 : Y-.4341 
360 GOSUB 2000 
400 SI2= .38: COL = 3 
410 X * .028 : Y-.361 : Z — 

420 GOSUB 2000 

430 X = .376 : Y-.474 : Z — 

440 GOSUB 2000 

450 X = .728 : Y-.363 : Z — -*7 

460 GOSUB 2000 

999 GOTO 5000 

1000 WRITE #1, COL. 

(X - Z*SIN 

((BETA - 90)*3.14159/1M)} 
*A,Y*B,(2*C0S((BE”A - 
90)*3.14159/186) )«C .SIZ 
1020 RETURN 


2000 WRITE #1, COL. (X - Z-S> 

((BETA - 90)*3.1415S/:»>) 
*A.Y*B.(2*C0S((BET* - 
90)*3.14159/180))«C„SIZ 
2020 WRITE #1, COL. (X - 2.=:% 
((BETA - 90)*3.1415S X" 
*A,(.5-Y)*B,(Z*CC$;.'3E^a - 
90)*3.14159/’ ■«; ,< 52 

2040 RETURN 
5000 CLOSE #1: END 


TEXT 


"Keyboard Efficiency.” See dvorak.bos for details. 


R™wV ntere - lin ®- b y- |in «- A line is entered by the 
RETURN key or is automatically accepted if the cursor 
reaches column 39; warning beeps are sounded past column 31 
After a line is entered, it is retyped by the computer as it 
uo wlth y +h?'i S? ,tinfl is Possible within a line by backing 
it eiiSJ L H-7 a 7r ?u d r * t yp in 9- 0nc « o line is analysed 
of uonftr nnH ? d,ted further. We suggest typing with full use 
of upper and lower case. However, the program wiI I run 
correctly if the CAPS LOCK is locked down for the entire 

Ih fted\o ha - ? aSe 'J! W, i‘ Infer use of the shift key for 
shifted special symbols, but not for capital letters. 

TO UNDERSTAND THE LISTING: 

}«f+ f +« 9e ^ S h+ e *?u Ud ! n ? the thumbs) are numbered 1 to 8 from 
left to right. The label K refers to Qwerty (K = 11 or 
Dvorak (K = 2). The variables CX(F.K) and CY(F,K) are the 
current column and row locations of finger F in keyboard K 

' r lncr ? mented by an amount from a 

DSfl ncf?'^ anCeS ’ ' n actual inches - called 

kovhonrH Th DS t I,d ) ar e computed by approximating the 
keyboard as a grouping of parallelograms with sides 0.75" 
(honzonta! key spacing) and 0.81" (measured along a 
diagonal from the upper left to the lower right, tilted 
approximately 23 degrees from the vertical). Like the Qwertv 
arZ ^ <? Qr ?' I* 1 P°ttern dates fr^tX*^ 

to f T ech ?"' cal typewriters when it was necessary 

somniA nA^ 7- f0r r th ® connect ing levers beneath the keysA 
sample DATA line (e.g.. 1066 DATA 66.B.4.1,-1.8.5,-1 -1 1) 
is interpreted as follows. ASCII code 66 is a capital B. In 
Qwerty, it Is typed by finger 4, moved one column to the 
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right and one row down relative to the home position; also, 
if CAPS LOCK is off, finger 8 (the little finger on the 
right hand) must reach down for the SHIFT key. In the Dvorak 
layout, B is typed by finger 5, one column to the left and 
one row down from the home position; if CAPS LOCK is off, 
finger 1 must strike the SHIFT key. Characters with ASCII 
codes above 122 or below 32 (mainly control characters) are 
ignored, except for left-arrow (ASCII 8), RETURN (ASCII 13), 
and ESCAPE (ASCII 27). 


simpl3.bix 

TEXT 

Programming Project: "A Simpl Compiler Part 3: Extensions," by Jonathan Amsterdam. 
February, page 102. Also download readsim3.me. 


Break the following modules out into their own files 
Start CodeGen.DEF 

DEFINITION MODULE CodeGen; 

(* * This module generates code from parse trees. *) 

FROM Node IMPORT node; 

FROM Symbol IMPORT symbol; 

EXPORT QUALIFIED genBlock, genGlobal, genLocals; 

PROCEDURE genBlock(nrnode); 

(* Generate code for a block of statements. *) 

PROCEDURE genGIobaI(s:symboI); 

(* Generate code for a global variable. *) 

PROCEDURE genLocaIs(routine:symboI); 

(* Generate code to set up the stack for local variables. *) 
END CodeGen. 


Start CodeGen.MOD 

IMPLEMENTATION MODULE CodeGen; 

(* Code Generator for the SIMPL compiler. 

Changes for part 3: 

1. Arrays handled. No arrays are initialized. Now, also, 
locals of any type are not initialized. 

2. IN/OUT handled. 

3. Array and string const assignment handled. 

4. String constant assignment handled. 

*) 

FROM MyTerminal IMPORT fatal; 

IMPORT MyTerminal; 

FROM InOut IMPORT WriteString, WriteLn, WriteCard; 

FROM Node IMPORT node, nodeClass, NodeClass, nodeEmpty, nodeFirst, nodeRest, 
nodejest, nodeThen, nodeElse, nodeStmts, nodeRHS, nodeLHS, nodeArgs, 
nodeRoutine, nodeExpr, nodeArg, nodeLeftArg, nodeRightArg, nodeOp, 
nodeSymbol, nodelnt, nodeBool, nodeNumFormaIs, nodeChar, 
nodeType, freeNode, nodeArray, nodeindex, nodeString; 

FROM CodeWrite IMPORT writeLabel, writeStringLabeI, writeStringBranch, 

writeCondBranch, writeBranch, writeSymPop, writeCall, writeChar, 
writeWritelnt, writelnt, writeReadlnt, writeReturn, writeFReturn, 
writeOp, writeBool, writeSymbol, writeWriteChar, writeReadChar, 
writeSetSP, writePop, writeLow, writeHigh, writeCopy, writeAddr, 
writeMin, writeContents, writeAref, recordstring; 

FROM Token IMPORT tokenClass, isRelation, stringType; 

FROM LexAn IMPORT err orFlag; 

FROM Symbol IMPORT symbol, numLocals, Class, modeType, 
symbolList, sISymbol, sINext, slEmpty; 

( continued ) 
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IMPORT Symbol; 
FROM Symbol Table 
FROM StrIngStuff 
FROM TypeChecker 


IMPORT tStrlng, lowFunc, 
IMPORT stringLen; 

IMPORT baseType; 


highFunc, 


t Integer, 


tChar, 


tBoo I e:*» 


(*** label generation ***) 

(* The code generator needs o supply of unique label names. *) 

MODULE Labe I Generator; 

EXPORT newLabeI, label; 

TYPE label = CARDINAL; 

VAR labelCount:CARDINAL; 

PROCEDURE newLabeI():Iabe I • 

BEGIN 

INC(IabeICount); 

RETURN IabeI(IabeI Count); 

END newLabeI; 

BEGIN 

labelCount :* 0; 

END LabeIGenerator; 


PROCEDURE genBlock(nrnode); 

(* This Is the Interface to generating statements. We 
doing generation If there has been an error. Also 
prr^K, Utlne t0 96t ° n empty node Orally); In that case 


don ’ t waste our t we 
11 * s possIbIe for * * : 
, we do nothing. 


IF (NOT errorFlag) AND (NOT nodeEmpty(n)) THEN 
IF nodeCIass(n) <> nLlst THEN 

ELSE MyTerminal - fata l(’genBlock: node class must be nLlst*); 


genStmts(n) 
freeNode(n) 

END; 


END; 

END genBlock; 


PROCEDURE genGIobaI(s:symboI); 

( * ?n t FA. t <;F h ? K 9 !°K b °! Sy T b0 ' ° S °s lQbel - Initial ize integers to 0. boolec-s 
to FALSE (which is also zero), chars to NUL (which is again zero) 

VAR nameistringType; ^ ° rr ° yS ' j ° St WMte ° • BL0CI< - N ° ^itia Iizatio-. 

sIze:CARDINAL; 

BEGIN 

IF NOT errorFlag THEN 

IF Symbol.class(s) = Global THEN 
Symbol.string(s, name); 
size := SymboI.size(SymboI.type(s)) ; 
wr I teStrIngLabeI(name); 

IF size = 1 THEN 

WriteSt ring(" 0"); 

ELSE ^ ' 


WriteString( M .BLOCK "); 
WrIteCard(size, 0); 

END; 

Wr i teLn; 

ELSE 


MyTerm i na I . Wr i teSt r i ng("genG I oba I : not a global* "V 
fatal(name); ^ 

END; 

END; 

END genGIobaI; 


PROCEDURE genLocaIs(routine:symboI); 
(* save space for locals on stack *) 
VAR n:CARDINAL; 

BEGIN 


n := sizeLocaIs(routine); 

IF n <> 0 THEN 

writeSetSP(INTEGER(n)); 
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END genLocals; 

PROCEDURE sizeLocaIs(routine:symboI):CARDINAL; 

VAR I oca Is:symboIList; 

sum:CARDINAL; 

BEGIN 

locals := SymboI.locaIs(routine); 
sum := 0; 

WHILE NOT slEmpty(locals) DO 

INC(sum, SymboI.size(SymboI.type(sISymboI(I oca Is)))); 
locals :* sINext(locals); 

END; 

RETURN sum; 

END si zeLocaIs; 


PROCEDURE genStmts(n:node); 

(* Generate a list of statements, If the node isn't empty. *) 
BEGIN 

IF NOT nodeEmpty(n) THEN 
genStmt(nodeFirst(n)); 
genStmts(nodeRest(n)); 

END; 

END genStmts; 


(*** Statements ***) 

PROCEDURE genStmt(mnode); 

BEGIN 

CASE nodeClass(n) OF 
nlf: genlfStmt(n); 
nWhile: genWhiIeStmt(n); 
nAssignment: genAssignStmt(n); 
nCall: genCaI I Stmt(n); 
nWrite: genWriteStmt(n); 
nRead: genReadStmt(n); 
nReturn: genReturnStmt(n); 

ELSE 

MyTermlnaI.fata I("genStmt: unknown statement type"); 

END; 

END genStmt; 


PROCEDURE genIfStmt(ninode); 

VAR labell, IabeI 2:IabeI; 

BEGIN 

labell :■ newLabelQ; 
genExpr(nodeTest(n)) ; 
writeCondBranch(EquaI, labell); 
genBlock(nodeThen(n)); 

IF nodeEmpty(nodeEIse(n)) THEN 
writeLabeI(IabeII); 

ELSE 

I abe12 :* newLabeI(); 
wr i teBranch(Iabe12); 
wr i teLabeI(IabeII); 
genBlock(nodeEIse(n)); 
writeLabeI(IabeI 2); 

END; 

END genlfStmt; 

PROCEDURE genWhiIeStmt(ninode); 

VAR testLabel, endLabeI;IabeI; 

BEGIN 

testLabel :« newLabel(); 
endLabel :« newLabel(); 
wr IteLabeI(testLabe I); 
genExpr(nodeTest(n)); 
writeCondBranch(EquaI, endLabeI); 
genBlock(nodeStmts(n)); 
wr1teBranch(testLabe I); 
wr iteLabeI(endLabeI); 

END genWhiIeStmt; 

PROCEDURE genAssignStmt(ninode); 

BEGIN 

(continued] 


(* generate test *) 

(* branch to else part if test false *) 
(* generate then part *) 

(* no else part *) 


* branch around els part *) 

* label for else part *) 

* generate else part *) 

* final label *) 


(* label for top of loop *) 

(* generate test *) 

(* if false, branch to end of loop *) 
(* generate loop body *) 

(* branch back to test *) 

(* end label *) 
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IF Symbol.class(baseType(nodeType(nodeLHS(n)))) ■ ArrayType THEN 
(* RHS had better be an array type too, or a string const *) 
genlndexf nodeRHSTn^; 
gen Index(nodeLHS(n)); 
computes Ize(nodeRHS(n), nodeLHS(n)); 
wr IteCopy; 

ELSE 

genExpr(nodeRHS(n)); (* generate the expression *) 

genScaIarAssign(nodeLHS(n)); 

END; 

END genAssignStmt; 

PROCEDURE genScaIarAssign(n:node); 

(* generate code to assign top of stack to n *) 

BEGIN 

IF nodeClass(n) * nlndex THEN 
genlndex(n); 
writePop; 

ELSIF SymboI.cI ass(baseType(nodeType(n))) = ArrayType THEN (* error * 
fata I(’genScaIarAssign: array type given*); 

ELSE (* a scalar variable *) 

writeSymPop(nodeSymboI(n)); (* pop result into the variable * 

END; 

END genScaIarAssign; 

PROCEDURE computesize(source, dest:node); 

(* Size for an array copy is tricky. The rules are: 

1. If the size of source and dest are known (i.e. they are not open 
arrays), then take the min. 

2. If the size of one or both isn't known, compute the min at runtime. 
VAR stype, dtype:symboI; 

BEGIN 

stype :* baseTypefnodeTypefsource)); 
dtype :*■ baseType(nodeType(dest)); 

IF SymboI.open(stype) OR SymboI.open(dtype) THEN 
gen3ize(source, stype); 
genSize(dest, dtype); 

writeMin; (* MIN instruction added for this purpose *) 

ELSIF nodeClass(source) - nString THEN 

IF nstringLen(source) + 1 < SymboI.size(dtype) THEN 
genSize(source, stype); 

ELSE 

genSize(dest, dtype); 

END; 

ELSIF NOT Symbol.equal(stype, dtype) THEN 
fatal('computeSize: not same type’); 

ELSE 

genSize(source, stype); 

END; 

END computeSize; 

PROCEDURE genSize(n:node; ntype:symboI); 

(* generate code to put size of n on stack; n must be of type array. *) 
BEGIN 

IF SymboI.open(ntype) THEN (* size = highBound - lowBound + 1 *) 
genHighBound(n); 
genLowBound(n); 
wr i teOp(Minus); 
wr i telnt(1); 
wr IteOp(PI us); 

ELSIF nodeClass(n) » nString THEN (* string const *) 
writelnt(INTEGER(nstringLen(n) + 1)); 

(* Important: +1 for null at end *) 

ELSE (* a non-open array variable *) 

writelnt(INTEGER(SymboI.size(ntype))); 

END; 

END genSize; 

PROCEDURE genCalI Stmt(n:node); 

BEGIN 

(* Here we do the special checks for the pseudofunctions LOW and HIG- 
IF SymboI.equaI(nodeRoutine(n), lowFunc) THEN 
genLowBound(nodeFirst(nodeArgs(n))); 

ELSIF SymboI.equaI(nodeRoutine(n), highFunc) THEN 
genHighBound(nodeFirst(nodeArgs(n))); 

ELSE (* a "real" function *) 
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genArgs(nodeRoutine(n), nodeArgs(n)); (* generate the arguments *) 
writeCalI(nodeRoutine(n)); (* generate a call instruction *) 

END; 

END genCalIStmt; 

PROCEDURE genArgs(routine:symboI; argIist:node); 

(* Iterate down the arglist and the list of the routine’s formals, 
and generate code for each argument *) 

VAR formlist:symbolList; 

BEGIN 

formlist := SymboI.forma Is(routine); 

(* assume number of formals = number of args *) 

WHILE NOT nodeEmpty(argIist) DO 

genArg(nodeFirst(arglist), siSymboI(formlist)); 
arglist := nodeRest(argIist); 
formlist := sI Next(form Iist); 

END; 

END genArgs; 

PROCEDURE genArg(arg:node; forma I:symboI); 

(* Generate code to push the argument on the stack, as follows: 

1. Argument is an array: 

la. If formal is open array, push high bound, low bound; 

lb. Push starting address, regardless 

2. Argument is a scalar: 

2a. If formal has mode IN, do the usual thing: genExpr. 

2b. Otherwise, push the address of the scalar. 

*) 

VAR argType:symboI; 

BEGIN 

argType :* baseType(nodeType(arg)); 

IF SymboI.cIass(argType) * ArrayType THEN 
IF SymboI.open(SymboI.type(formaI)) THEN 
genHighBound(ara); 
genLowBound(arg); 

END; 

genlndex(arg); 

ELSIF SymboI.cIassfargType) « ScalarType THEN 
IF SymboI.mode(forma I) ■ min THEN 
genExpr(arg); 

ELSE 

genlndex(arg); 

END; 

ELSE 

fatal(’genArg: argtype not a type object’); 

END; 

END genArg; 


PROCEDURE genWr1teStmt(n:node); 

(* Generate code to write the arguments to the screen. WRITE can take any 
number of arguments. *) 

VAR arglist:node; 

argType:symbol; 

BEGIN 

arglist :- nodeArgs(n); 

WHILE NOT nodeEmpty(argI 1st) DO 
genExpr(nodeFirst(argIist)); 

argType :« baseType(nodeType(nodeFirst(argIist))); 

IF Symbol.equal(argType, tlnteger) THEN 
wr iteWritelnt; 

ELSE (* it’s a char *) 
wr iteWriteChar; 

END; 

arglist :■ nodeRest(argIist); 

END; 

END genWr1teStmt; 

PROCEDURE genReadStmt(n:node); 

(* Generate code to read from the terminal. READ can take any number of 
arguments. *) 

VAR argI 1st:node; 

argType:symbol; 

BEGIN 

arglist :« nodeArgs(n); 

WHILE NOT nodeEmpty(argIist) DO 

[continued) 
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argType baseType(nodeType(nodeFIrst(argl ist))); 

IF Symbol.equal(argType, tlnteger) THEN 
wr IteReadlnt; 

genScaIarAssign(nodeF!rst(arglist)); 

ELSE (* a char *) 
wr IteReadChar; 

genScalarAssign(nodeFir$t(argllst)); 

END; 

argllst ;■ nodeRest(argI Ist); 

END; 

END genReadStmt; 

PROCEDURE genReturnStmt(n:node); 

BEGIN 

IF nodeEmpty(nodeExpr(n)) THEN (* a procedure return *) 
wr IteReturn(nodeNumFormaI s(n)); 

ELSE: (* a function return *) 

genExpr(nodeExpr(n)); 
wrIteFReturn(nodeNumFormaIs(n)); 

END; 

END genReturnStmt; 


(*** expressions ***) 


PROCEDURE genExpr(n;node); 
BEGIN 


CASE nodeClass(n) OF 

nUnop; genExpr(nodeArg(n)); 
writeOp(nodeOp(n)); 

| nOp: IF (nodeOp(n) - And) OR (nodeOp(n) « Or) THEN 

genLogicalOp(n); 

ELSE 


genExprfnodeLeftArg(n)}; 
genExpr(nodeRightArg(n)); 
writeOp(nodeOp(n)); 

END; 

nlnt: writelnt(nodelnt(n)); 

nBool: writeBooI(nodeBooI(n)); 
nChar: writeChar(nodeChar(n)); 
nSymboI:writeSymboI(nodeSymboI(n)); 
nCalI; genCalIStmt(n); 
nlndex: genlndex(n); 

writeContents; 

ELSE MyTerminaI.fata I("genExpr: unknown expression type"); 

END; 

END genExpr; 


PROCEDURE genLogicaIOp(nmode); 

(* AND * s and OR’s end up here. We generate code to evaluate only the firs' 
if possible. *) 

VAR I obeli, label 2:label; 

BEGIN 

IabeII := newLabeI(); 

Iabel2 := newLabel(); 
genExpr(nodeLeftArg(n)); 

IF nodeOp(n) = And THEN (* we branch to FALSE if the first was FALSE - 
writeCondBranch(Equal, label 1); 

ELSE (* it's OR; we branch to TRUE if the first was TRUE *) 
writeCondBranch(Greater, label 1); 

END; 

genExpr(nodeRightArg(n)); (* if the first one failed to decide, the vc 

. v of the 2nd is the value of the whole thi-: 

writeBranch(Iabe12); 
writeLabeI(IabeII); 

writeBooI(nodeOp(n) = Or); (* write TRUE if OR, FALSE if AND *) 
writeLabeI(Iabe12); 

END genLogicalOp; 


PROCEDURE genlndex(n:node); 

(* Generates an array index. Ends up with element address on top of stac- 
Works fine for whole arrays, too—puts the starting address on the stc:* 
In fact, works fine for scalar symbols tool And for strings. *) 

VAR arrayVarmode; 

BEGIN 

IF nodeClass(n) * nSymboI THEN 
writeAddr(nodeSymboI(n)); 
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ELSIF nodeClass(n) =* nString THEN 
genString(n); 

ELSIF nodeClass(n) = nlndex THEN 
arrayVar := nodeArray(n); 
genlndex(arrayVar); 
genLowBound(arrayVar); 
genHighBound(arrayVar); 
genExpr(nodeIndex(n)); 

writeAref(SymboI.size(baseType(nodeType(n)))); 

ELSE 

fatal('genlndex: node not symbol, string or Index*); 

END; 

END genlndex; 

PROCEDURE genLowBound(arrayVar:node); 

VAR arrayType:symbol; 

BEGIN 

arrayType := baseType(nodeType(arrayVar)); 

IF nodeCIass(arrayVar) = nSymboI THEN 
IF SymboI.open(arrayType) THEN 

wrIteLow(nodeSymboI(arrayVar)); 

ELSE 

wrItelnt(SymboI.IowBound(arrayType)); 

END; 

ELSIF nodeCIass(arrayVar) = nString THEN 
wr I telnt(0); 

ELSIF nodeCIass(arrayVar) = nlndex THEN 
wrItelnt(SymboI.IowBound(arrayType)); 

ELSE 

fatal('genLowBound: not symbol, string or index*); 

END; 

END genLowBound; 

PROCEDURE genHighBound(arrayVarinode); 

VAR arrayTypeisymboI; 

BEGIN 

arrayType := baseType(nodeType(arrayVar)); 

IF nodeCIass(arrayVar) = nSymbol THEN 
IF SymboI,open(arrayType) THEN 

writeHigh(nodeSymboI(arrayVar)); 

ELSE 

writelnt(SymboI.highBound(arrayType)); 

END; 

ELSIF nodeCIass(arrayVar) « nString THEN 

writelnt(nstringLen(arrayVar)-l); (* does not include 0 at end *) 
ELSIF nodeCIass(arrayVar) = nlndex THEN 
writelnt(SymboI.highBound(arrayType)); 

ELSE 

fata I('genHighBound: not symbol or index*); 

END; 

END genHighBound; 

PROCEDURE genString(nmode); 

VAR lab:label; 

s:stringType; 

BEGIN 

lab :« newLabeI(); 
nodeString(n, s); 
recordString(lab, s); 

END genString; 

PROCEDURE nstringLen(n:node):CARDINAL; 

VAR s:stringType; 

BEGIN 

nodeString(n, s); 

RETURN stringLen(s); 

END nstringLen; 

BEGIN 

END CodeGen. 


Start CodeWrite.DEF 


(continued) 
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DEFINITION MODULE CodeWrlte; 

(* This module outputs the code for the SIMPL compiler. *) \ 

FROM Symbol IMPORT symbol; 

FROM Token IMPORT tokenCloss, stringType; 

EXPORT QUALIFIED writeLabel, writeStringLabeI, writeRoutineLabeI, writeHalt. 

writeStringBranch, writeBronch, writeCondBranch, writePop, writeCall 
writeWritelnt, wrlteReadlnt, wrlteReturn, writeFReturn, writeOp, 
wrltelnt, writeBool, writeSymbol, writeChar, writeSymPop, 
writeWriteChar, writeReadChar, writeLow, writeHigh, writeAddr, 
writeCopy, writeMin, writeContents, writeSetSP, writeAref, 
recordstring, writeStrings; 


PROCEDURE writeLabeI(c:CARDINAL); 

(* Writes an “L" followed by the number, then a colon. *) 

PROCEDURE writeStringLabeI(s:ARRAY OF CHAR); 

(* Just writes the string followed by a colon. *) 

PROCEDURE writeRoutineLabeI(routine:symboI); 

(* Writes the name of the routine followed by a colon, and writes (on the 
screen) the procedure name so the user knows it’s being compiled. *) 

PROCEDURE wrIteStringBranch(s: ARRAY OF CHAR); 

(* Write a branch followed by the string *) 

PROCEDURE writeCondBranch(tc:tokenCI ass; crCARDINAL); 

(* Write a conditional branch (Equal, Greater or Less) followed by "L“, the- 
the number. *) 

PROCEDURE writeBranch(c:CARDINAL); 

(* Write an unconditional branch to the label. *) 

PROCEDURE writeCalI(s:symboI); 

(* Generate a call instruction with the symbol *) 

PROCEDURE writeWritelnt; 

PROCEDURE writeReadlnt; 

PROCEDURE writeWriteChar; 

PROCEDURE writeReadChar; 

(* instructions for I/O *) 

PROCEDURE writeReturn(numFormaIs:CARDINAL); 

PROCEDURE writeFReturn(numFormaIs:CARDINAL); 

(* Two types of return instructions; both take the number of formals as arg. 
PROCEDURE writeOp(tc:tokenCI ass); 

(* Write the instruction corresponding to the operator *) 

PROCEDURE writelnt(i;INTEGER); 

PROCEDURE writeBool(b:BOOLEAN); 

PROCEDURE writeChar(c:CHAR); 

(* Write pushes for these constants. *) 

PROCEDURE writeSymboI(s:symboI); 

(* Generate the appropriate push instruction for the symbol *) 

PROCEDURE writeSymPop(s:symboI); 

(* Generate the appropriate pop instruction for the symbol *) 

PROCEDURE writeHalt; 

PROCEDURE writeAddr(s:symbol); 

(* Put the address of the symbol on the stack *) 

PROCEDURE writeLow(s:symboI); 

PROCEDURE writeHigh(s:symboI); 

(* For low and high bounds of open arrays. *) 

PROCEDURE writeCopy; 

PROCEDURE writeMin; 

PROCEDURE writeContents; 

PROCEDURE writePop; 

PROCEDURE writeSetSP(i;INTEGER); 

PROCEDURE writeAref(size:CARDINAL); 
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PROCEDURE recordStrIng(IabrCARDINAL; VAR s:stringType); 

(* remembers a string, to be output later *) 

PROCEDURE writeStrings; 

(* Writes out remembered strings, preceded by their labels. *) 
END CodeWrite. 


Start CodeWrite.MOD 


MPLEMENTATION MODULE CodeWrite; 

FROM InOut IMPORT WriteString, WriteLn, Writelnt, WriteCard; 

(* We can * t use Write because of a conflict inside tokenClass *) 

IMPORT InOut; ' 

FROM Symbol IMPORT symbol, Class, modeType; 

IMPORT Symbol; 

FROM SymbolTable IMPORT currentLexLeveI; 

FROM Token IMPORT tokenClass, stringType; 

IMPORT MyTerminal; 

PROCEDURE writeStringLabeI(s:ARRAY OF CHAR); 

BEGIN 

Wr i teString(s); 

Wr i teString(’: *); 

END writeStringLabeI; 

PROCEDURE writeRoutineLabel(routine:symboI); 

VAR name:stringType; 

BEGIN 

wr iteRoutineName(rout1ne); 

WriteString(*: ’); 

Wr i teLn; 

SymboI.string(routine, name); 

MyTerminal.WriteString(name); 

MyTerminal .Wr i teLnStr ing(" .. . •'); 

END writeRoutineLabeI; 

PROCEDURE writeRoutineName(routine:symboI); 

VAR name:stringType; 

BEGIN 

SymboI.string(routine, name); 

Wr i teString(name); 

IF Symbol.lexLevel(routine) <> 0 THEN 
WriteInt(Symbol.offset(routine), 0); 

END; 

END writeRoutineName; 

PROCEDURE writelabeI(c:CARDINAL); 

BEGIN 

InOut.Write(’L’); 

WriteCard(c, 0); 

InOut.Wr f te(•:•); 

Wr iteLn; 

END writeLabeI; 

PROCEDURE writeStringBranch(s:ARRAY OF CHAR); 

BEGIN ' 

writeOpCode(’BRANCH *); 

WriteLnString(s); 

END writeStringBranch; 

PROCEDURE writeBranch(c:CARDINAL); 

BEGIN 

wr i t eOpCode(’BRANCH L'); 

WriteCard(c, 0); 

WriteLn; 

END writeBranch; 

PROCEDURE writeCondBranch(tc:tokenClass; c:CARDINAL); 

BEGIN ' 

CASE tc OF 

Equal; writeOpCode(’BREQL L'); 

| Less: writeOpCode(’BRLSS L'); 

( continued ) 
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| Greater:writeOpCode(’BRGTR L'); 

ELSE 

MyTerminal.fatal(*wrIteCondBranch: unknown branch type’); 

END; 

WrIteCard(c, 0); 

WriteLn; 

END writeCondBranch; 

PROCEDURE wrIteWritelnt; 

BEGIN 

writeOpCode('WRINT’); 

Wr i teLn; 

END writeWrftelnt; 

PROCEDURE writeReadlnt; 

BEGIN 

writeOpCode(’RDINT’); 

Wr l teLn; 

END writeReadlnt; 

PROCEDURE wr I teWriteChar; 

BEGIN 

wr 11 eOpCode(* WRCHAR *); 

Wr l teLn; 

END writeWriteChar; 

PROCEDURE writeReadChar; 

BEGIN 

writ eOpCode(*RDCHAR *); 

WrIteLn; 

END writeReadChar; 

PROCEDURE writeHalt; 

BEGIN 

writeOpCode('HALT*); 

WriteLn; 

END writeHalt; 

PROCEDURE writeReturn(numFormaIs:CARDINAL); 

BEGIN 

writeOpCode(’RETURN ’); 

WriteCard(numFormaIs, 0); 

Wr1teLn; 

END writeReturn; 

PROCEDURE writeFReturn(numFormaIs:CARDINAL); 

BEGIN 

wr iteOpCode(’FRETURN ’); 

WriteCard(numFormaIs, 0); 

Wr ? teLn; 

END writeFReturn; 

PROCEDURE writelnt(i;INTEGER); 

BEGIN 

writeOpCode(* PUSHC ’); 

Wr i telnt(i, 0); 

Wr i teLn; 

END writelnt; 

PROCEDURE writeChar(c:CHAR); 

BEGIN 

writeOpCode(’PUSHC ’); 

InOut.Write(.); 

InOut.Write(c); 

WriteLn; 

END writeChar; 

PROCEDURE writeBooI(b:BOOLEAN); 

BEGIN 

IF b THEN 

writelnt(1) ; 

ELSE 

wr i telnt(0); 

END; 

END writeBooI; 
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PROCEDURE writeSymPop(s:symboI); 

(* Not defined on array symbols. *) 

BEGIN 

wrIteSymAddr(s, "POPC ", "POPL ", "PUSHL "); 

IF SymboI,cIass(s) = Formal THEN 
wrItePop; 

END; 

END writeSymPop; 

PROCEDURE wrIteSymboI(s:symboI); 

(* Put the contents of the symbol on the stack. Not defined for 
array symbols. *) 

BEGIN 

writeSymAddr(s, "PUSH ", "PUSHL ", "PUSHL "); 

IF (Symbol.class(s) = Formal) AND (SymboI.mode(s) = mlnOut) THEN 
wrIteContents; 

END; 

END writeSymboI; 

PROCEDURE writeAddr(s:symboI); 

(* Put the address of the symbol on the stack. Rules: 
array: 

gIobaI: pushc; 
locaI: addrI; 
forma I: push I; 
sea Iar: 

gIobaI: pushc; 
locaI: addrI; 

formal: IN: addrl; OUT, IN OUT; pushl 

*) 

BEGIN 

IF (Symbol.cI ass(SymboI.type(s)) * ScalarType) AND 
(Symbol.class(s) * Formal) AND 
(SymboI.mode(s) * min) THEN 

writeSymAddr(s, "dummy", "dummy", "ADDRL "); 

ELSE J 

writeSymAddr(s, "PUSHC ", "ADDRL ", "PUSHL "): 

END; ' 

END wrfteAddr; 

PROCEDURE writeSymAddr(s:symboI; global, local, formal:ARRAY OF CHAR); 

VAR name:strIngType; 

BEGIN 

Symbol.string(s, name); 

IF SymboI.cIass(s) ■ Global THEN 
writeOpCode(gIobaI); 

Wr I teLnStrIng(name); 

ELSE 

IF Symbol.class(s) « Local THEN 
wr IteOpCode(I oca I); 

ELSIF Symbol.class(s) = Formal THEN 
wr IteOpCode(forma I); 

ELSE 

MyTerminaI.fata I(’writeSymAddr: not variable*): 

END; 

Wr i telnt(cur rentLexLeveI() - SymboI.IexLeveI(s), 0); 

Wr i teString(*, *); 

Wr i telnt(SymboI.offset(s), 0); 
wr iteComment(name); 

END; 

END writeSymAddr; 

PROCEDURE writeCaI I(s:symboI); 

BEGIN 

wr iteOpCode("CALL "); 
wr i teRoutIneName(s); 

Wr i teStrIng(", "); 

Wr Itelnt(cur rentLexLeveI() - SymboI.IexLeveI(s), 0); 

WriteLn; 

END writeCalI; 

PROCEDURE writeOp(tc:tokenCIoss); 

BEGIN 

CASE tc OF 

Plus: writeOpCodef *ADD*); 

I Minus: writeOpCode(*SUB*); 

( continued ) 
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UMinus: 
Times: 
Divide: 

Not: 

Equal: 
Greater: 
Less: 
NotEqual: 
LessEquaI: 
GreaterEqua 
ELSE MyTerminal 
END; 

Wr1teLn; 

END writeOp; 


writeOpCodef ’NEG*); 
wr i teOpCode ( 'MUL') ; 
wr iteOpCode(’DIV*); 
wr i teOpCode ( ’NOT*) ; 
wr i teOpCode ( ’EQUAL * ) ; 
wr IteOpCode(‘GREATER’); 
wr 1teOpCode(’LESS *); 
wr 1teOpCode(’NOTEQL ’); 
wr 1 teOpCode (’ LSSEQL '); 

: wr 1teOpCode(’GTREQL'); 
fataI("wrIteOp: unknown operator"); 


PROCEDURE WriteLnString(s:ARRAY OF CHAR); 
BEGIN 

WriteString(s); 

WriteLn; 

END WriteLnString; 


PROCEDURE writeOpCode(s:ARRAY OF CHAR); 
BEGIN 

Wr iteStr I ng('* "); 

WriteString(s); 

END writeOpCode; 

PROCEDURE wr i teComment(s‘.ARRAY OF CHAR); 
BEGIN 

Wr iteStrlng(" ; "): 

Wr iteStrlng(s); 

Wr1teLn; 

END wr1teComment; 


PROCEDURE writeCopy; 
BEGIN 

wr iteOpCode("COPY"); 
WriteLn; 

END writeCopy; 

PROCEDURE writeMin; 

BEGIN 

wr1teOpCode("MIN"); 
WriteLn; 

END writeMin; 

PROCEDURE writePop; 

BEGIN 

writeOpCode("POP"); 
WriteLn; 

END writePop; 


PROCEDURE writeContents; 
BEGIN 

writeOpCode("CONTENTS"); 
WrIteLn; 

END writeContents; 


PROCEDURE writeLow(s:symbol); 

(* stack looks like this: 
highBound 
IowBound 

startaddr <— offset 

*) 

BEGIN 

wrIteOpCode("PUSHL "); 

Writelnt(currentLexLeveI() - 
Wr iteStringC , *); 

Writelnt(Symbol.offset(s)+1, 
writeComment("LOW"); 

END writeLow; 


SymboI.IexLeveI(s), 0); 

0 ); 


PROCEDURE writeHigh(s:symbol); 
(* stack looks like this: 

| highBound | 
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lowBound | 

j startaddr j <— offset 

*) 

BEGIN 

wr IteOpCode("PUSHL 

Writelnt(currentLexLeveI() - SymboI.IexLeveI(s), 0); 

WriteString(’, *); 

Wr i telnt(SymboI.offset(s)+2, 0); 
wr iteComment("HIGH"); 

END writeHigh; 

PROCEDURE writeSetSP(i:INTEGER); 

BEGIN 

writeOpCode("SETSP "); 

Writelnt(i, 0); 

WriteLn; 

END writeSetSP; 

PROCEDURE writeAref(size:CARDINAL); 

BEGIN 

writ eOpCode("AREF "); 

WriteCard(size, 0); 

Wr i teLn; 

END writeAref; 

MODULE Strings; (* for handling string constants *) 

FROM MyTerminal IMPORT fatal; 

FROM InOut IMPORT Write, EOL; 

IMPORT writeLabel, WriteString, WriteLn, WriteCard, stringType, 
writeOpCode, writeComment; 

EXPORT writeStrings, recordstring; 

CONST maxStrings ■ 20; (* max string consts per routine *) 

TYPE stringRec * RECORD 

string:stringType; 
label -.CARDINAL; 

END; 

VAR strings: ARRAY[1..maxStrings] OF stringRec; 
nStrings:[0..maxStrings]; 

PROCEDURE recordString(Iab:CARDINAL; VAR s:stringType); 

(* record the string in the array and write code to push its address *) 
BEGIN 

IF nStrlngs ■ maxStrings THEN 

fatal(*too many strings in routine'); 

ELSE 

INC(nStrlngs); 

WITH strings[n$trings] DO 
label :■ lab; 
string := s; 

END; 

writeOpCode(’PUSHC L'); 

Wr1teCard(Iab, 0); 

WriteLn; 

END; 

END recordstring; 

PROCEDURE writeStrings; 

VAR 1:CARDINAL; 

BEGIN 

FOR i :* 1 TO nStrings DO 

writeLabel(strings[i].label); 

WriteString(* "’); 

formatString(strings[i].string); 

WriteStrlng(’" ’); 

WrIteCard(0, 0); 

WrIteLn; 

END; 

nStrings :« 0; 

END wrIteStrings; 

PROCEDURE formatstring(VAR s:ARRAY OF CHAR); 

(* puts slashes back in *) 

CONST Tab - 11C; 

VAR i:CARDINAL; 


(continued) 
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BEGIN 

i 0; 

WHILE (i <- HIGH(s)) AND (s[i] <> 0C) DO 
IF s [ I ] - THEN 

WriteStrIng(*\"'); 

ELSIF s[i] - EOL THEN 
WriteString("\n"); 

ELSIF s[i] * Tab THEN 
Wr I teString("\t"); 

ELSIF s[I] - "\" THEN 
WrlteStrlng("\\"); 

ELSE 

WrIte(s[i ]); 

END; 

INC(I); 

END; 

END formatstring; 

BEGIN (* module Strings *) 
nStrings :* 0; 

END Strings; 

BEGIN 

END CodeWrite. 


Start Compiler.MOD 


MODULE CompiIer; 

(* A compiler for the SIMPL programming language. 

Copyright 1985 by Jonathan Amsterdam. All Rights Reserved. 

See the BYTE article "A SIMPL Compiler" for more information. 

Module map, roughly in order of low to high level: 


CharStuff 
StringStuff 
MyTermina1 
LexAnStuf f 

Low-level character utilities \ 

Low-level string utilities 

Low-level terminal I/O utilities 

Toolkit for building lexical analyzers / 

used in prev :-s 
projects 

Token 

Symbo1 

Node 

Token, tokenList and typeType data types 
Symbol, symbolList and related data types 
Node and related data types 


Ini t 

TypeChecker 

LexAn 

Symbo1 Tab 1e 
CodeWrite 
CodeGen 

Initialization of compiler 

Procedures to do type-checking 

Lexical analyzer for compiler 

Compiler symbol table 

Actual output of code 

Code generation 


ExprParser 
Routines 
Parser 

Parses expressions 

Parses procedure and function declarations 
Main parser 



The module Debug, also supplied, is not used by the compiler, but contc -s 
routines useful in debugging the compiler. 

I would appreciate hearing about any bugs in the code. My BIX name is 
jba. —Jonathan Amsterdam 

*) 

FROM InOut IMPORT Openlnput, OpenOutput, Closelnput, CloseOutput; 

FROM MyTerminal IMPORT ClearScreen, pause, WriteLnString; 

FROM Parser IMPORT program; 

IMPORT Init; 

BEGIN 

CIearScreen; 

WriteLnString("SIMPL Compiler V2.0 n ); 

Openlnput(’SMP*); 

OpenOutput(’ASM’); 

Init.enterKeywords; 
program; 

Closelnput; 
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CloseOutput; 
pause(‘Done—'); 
END CompiIer. 


Start ExprParser.DEF 


DEFINITION MODULE ExprParser; 

(* The part of the parser that handles expressions. 

Syntax: 

<expr>::= <expr>|<reIexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> 
<relexpr> ::= <intexpr> | <intexpr> <relation> <intexpr> 

<intexpr> <term> | <term> + <intexpr> | <term> - <intexpr> 

<term> :;= <factor> | <factor> * <term> | <factor> / <term> 

<factor> <idOrIndex> | <number> | <call> | <char> 

- <factor> j NOT <factor> | ( <expr> ) | <string> 
<id0rlndex> <id> | <idOrIndex> [ <expr> ] | <id> [ <exprlist> ] 

*) 

FROM Node IMPORT node; 

FROM Symbol IMPORT symbol; 

EXPORT QUALIFIED expr, idOrlndex; 

PROCEDURE expr()inode; 

PROCEDURE id0rlndex(sisymboI)inode; 

END ExprParser. 


Start ExprParser.MOD 


IMPLEMENTATION MODULE ExprParser; 

(* Handles parsing of expressions, which are tricky because we have to 

make the operators left-associative, whereas the normal recursive descent 
grammar would have them be right-associative. 

The problem Is that the trees are build from the right. To make 
them get built from the left, we pass to expr, relexpr, intexpr and term 
the partial tree constructed from the left, and each of these procedures 
hooks that tree on to the one it parses in the appropriate way. 

Changes for part 3: 

1. Type coercion functions are handled. 

2. Strings handled. 

3. Array indexing handled. 

*) 

FROM Token IMPORT token, tokenClass, IsRelation; 

FROM LexAn IMPORT getToken, ungetToken, tokenErrorCheck, compError, 
getTokenCI ass, peekTokenCI ass; 

FROM Symbol IMPORT symbol, Class, modeType; 

IMPORT Symbol; 

FROM SymbolTable IMPORT findSymbol, tlnteger; 

FROM Node IMPORT node, emptyNode, makeOpNode, makeUnopNode, makelntegerNode, 
makeBooIeanNode, makeSymboI Node, makeCaI I Node, makeStringNode, nodeEmpty, 
makeCharNode, nodeFirst, nodeRest, makelndexNode, setNodeType, nodeType; 

FROM Parser IMPORT actuals; 

FROM TypeChecker IMPORT indexCheck; 

CONST dummy ■ Period; 

(* <expr>::■ <expr>|<reIexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> *) 

PROCEDURE expr()inode; 

BEGIN 

RETURN expr1(emptyNode, dummy); 

END expr; 

PROCEDURE expr1(I eft inode; op:tokenClass):node; 

VAR ninode; 
t:token; 

[continued) 
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BEGIN 

n :■= relexprQ; 
getToken(t); 

IF (t.class » And) OR (t.closs - Or) THEN 

RETURN expr1(buildTree(op, left, n), t.class); 

ELSE 

ungetToken; 

IF nodeEmpty(left) THEN 
RETURN n; 

ELSE 

RETURN makeOpNode(op, left, n); 

END; 

END; 

END expr1; 

(* <relexpr> ;<lntexpr> | <lntexpr> <relation> <intexpr> *) 

PROCEDURE re Iexpr();node; 

(* Here we don't have to worry about associativity since relations aren't 
associative! *) 

VAR n:node; 

t: token; 

BEGIN 

n :« intexpr(emptyNode, dummy); 
getToken(t); 

IF isReI ation(t.cI ass) THEN 

RETURN makeOpNode(t.cI ass, n, intexpr(emptyNode, dummy)); 

ELSE 

ungetToken; 

RETURN n; 

END; 

END re Iexpr; 

(* <intexpr> :<term> | <term> + <intexpr> | <term> - <intexpr> *) 

PROCEDURE intexpr(I eft:node; op;tokenCI ass);node; 

VAR n:node; 

t;token; 

BEGIN 

n :» term(emptyNode, dummy); 
getToken(t); 

IF (t.class = Plus) OR (t.class = Minus) THEN 

RETURN Intexpr(buildTree(op, left, n), t.class); 

ELSE 

ungetToken; 

IF nodeEmpty(Ieft) THEN 
RETURN n; 

ELSE 

RETURN makeOpNode(op, left, n); 

END; 

END; 

END intexpr; 

(* <term> <factor> | <factor> * <term> | <factor> / <term> *) 

PROCEDURE term(Ieft;node; op;tokenCIass):node; 

VAR ninode; 

t: token; 

BEGIN 

n :*= factorQ; 
getToken(t); 

IF (t.class = Times) OR (t.class = Divide) THEN 
RETURN term(buiIdTree(op, left, n), t.class); 

ELSE 

ungetToken; 

IF nodeEmpty(Ieft) THEN 
RETURN n; 

ELSE 

RETURN makeOpNode(op, left, n); 

END; 

END; 

END term; 

(* <factor> ::= <id> | <number> | <caI I> j <char> | - <factor> | NOT <factcr> ; 

( <expr> ) | <string> | <index> *) 

PROCEDURE factor():node; 

VAR ninode; 

t;token; 

BEGIN 

getToken(t); 
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CASE t.cl ass OF 

Int: RETURN makeIntegerNode(t.integer); 

Character: RETURN makeCharNode(t.ch); 

String: RETURN makeStringNode(t.string); 

Minus: RETURN makeUnopNode(UMi nus , factorQ); 

Not: RETURN makeUnopNode(Not, factorQ); 

True: RETURN makeBooIeanNode(TRUE); 

False: RETURN makeBooIeanNode(FALSE); 

Lparen: 

n := expr(); 

tokenErrorCheck(Rparen, ’Right paren expeced'); 

RETURN n; 

| Identifier: RETURN Id(t); 

ELSE 

compError('bad factor'); 

RETURN emptyNode; 

END; 

END factor; 

PROCEDURE Id(t:token):node; 

VAR s:symboI; 

BEGIN 

s := findSymboI(t.string); 

CASE SymboI.cIass(s) OF 

Func: RETURN makeCaI INode(s, actuals()); 

| Proc: compError('procedures cannot be used in an expression'); 

RETURN emptyNode; 

1 ArrayType, ScalarType: RETURN typeCoerce(s, actuals()); 

Global, Local, Formal: (* it's a variable or index*) 

IF (Symbol.class(s) « Formal) AND (SymboI.mode(s) = mOut) THEN 
compError("can't use an OUT formal in an expression"); 

END; 

RETURN idOrIndex(s); 

ELSE (* ignore *) 

RETURN emptyNode; 

END; 

END Id; 

(* <id0rlndex> <id> | <id0rlndex> [ <expr> ] 

That’s the "official" syntax. It's easier to treat it as: 

<id0rlndex> ::» <id> <indices> 

<indices> <empty> | [ <exprOrExprIist> ] <indices> 

The beginning <id> has already been read and looked up. *) 

PROCEDURE idOrIndex(s:symboI):node; 

BEGIN 

IF (peekTokenCIass() ** Lbracket) AND 

(Symbol.cIass(SymboI.type(s)) <> ArrayType) THEN 
compError("array variable expected"); 

END; 

RETURN indices(makeSymboI Node(s)); 

END idOrlndex; 

PROCEDURE indices(n:node):node; 

BEGIN 

IF getTokenClass() = Lbracket THEN (* array index *) 

RETURN indicesl(n); 

ELSE (* no Index *) 
ungetToken; 

RETURN n; 

END; 

END indices; 

PROCEDURE indices1(n:node):node; 

(* Like indices, except it starts with expression instead of Lbracket *) 

VAR exp:node; 

tc:tokenClass; 

BEGIN 

IF Symbol.class(nodeType(n)) <> ArrayType THEN 
compError("too many indices for array"); 

END; 

exp :«= expr(); 

IndexCheck(exp); 
tc :* getTokenClass(); 

IF tc - Rbracket THEN 

RETURN indices(makeIndexNode(n, exp)); 

ELSIF tc ■ Comma THEN 

( continued ) 
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RETURN indices1(makeIndexNode(n, exp)); 

ELSE 

e >^T..S? n,pError ( Uri9ht bracket or comma expected"): 
RETURN emptyNode; 

END; 

END Indices'!; 


PROCEDURE bulIdTree(op:tokenCI ass; nl, n2:node):node; 

BEGIn' S * th * k#y h0Cl< th0t bullds trees up from the left If necessary. *) 

IF nodeEmpty(nl) THEN 
RETURN n2; 

ELSE 

RETURN makeOpNode(op, nl, n2); 

END; 

END buildTree; 

PROCEDURE typeCoerce(typeObject:symboI; actuaI inode)mode; 

(* Changes the type of the actual to typeObject. actual should be a list 

tv D eOb ieet n ^KIot«%h C + Ua ' ' S tyP ! * h ° Uld h ° Ve the SOme size 08 the 
nhii?+i ! th ? t y ? u can do S0 T* Pre^y evil things with this 

arrayf^' 2 [1 sf ^ m,n 9 an orray[1..10][1..2] into an 

BEGIN " " J ' * 

IF nodeEmpty(actuaI) THEN 

RETURN*” actual* coercion functions must take an argument’); 

ELSE 

IF NOT nodeEmpty(nodeRest(actuaI)) THEN 

compError(* type coercion functions take only one argument 8 ): 

(* ...but we’ll set the first argument anyway *) 

IF HucZ 1 * slz ®( typ ® 0b j ect ) <> SymboI.size(nodeType(nodeFirst(actuc 
THEN compEr ror( types not of same size’): 

END; ' 

setNodeType(nodeFirst(actual), typeOb iect)• 

RETURN nodeFIrst(actuaI); ' 

END; 

END typeCoerce; 

BEGIN 

END ExprParser. 


Start Init.DEF 
====== 

DEFINITION MODULE Init; 

EXPORT QUALIFIED enterKeywords; 
PROCEDURE enterKeywords; 

END Init. 

Start Init.MOD 

IMPLEMENTATION MODULE Init; 

FROM SymboI Table IMPORT enterKeyword; 
FROM Token IMPORT tokenCI ass; 


PROCEDURE enterKeywords; 

BEGIN 

enterKeyword(’AND’, And); 
enterKeyword(’ARRAY’, Array); 
enterKeyword(’BEGIN’, Begin); 
enterKeywordf’DO’, Do); 
enterKeyword(’ELSE’, Else); 
enterKeywordf’ELSIF’, Elsif); 
enterKeyword(’END’, End); 
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enterKeywordf'FALSE', False); 
enterKeyword(’FUNCTION*, Function); 
enterKeyword(* IF *, If); 
enterKeyword(* IN*, In); 
enterKeywordf*NOT*, Not); 
enterKeyword(*0F*, Of); 
enterKeyword(’OR*, Or); 
enterKeyword(’OUT*, Out); 
enterKeywordf’PROCEDURE*, Procedure); 
enterKeyword(’PROGRAM’, Program); 
enterKeywordf’READ*, Read); 
enterKeyword(’RETURN*, Return); 
enterKeywordf’THEN’, Then); 
enterKeyword(’TRUE *, True); 
enterKeywordf’TYPE *, Type); 
enterKeyword(*VAR*, Var); 
enterKeyword(’WHILE’, While); 
enterKeyword(’WRITE’, Write); 

END enterKeywords; 

BEGIN 

END Init. 


Start LexAn.DEF 


DEFINITION MODULE LexAn; 

(* The lexical analyzer for the SIMPL compiler. It uses the InOut module 
do input, so you can get input from a file by redirecting it with 
InOut.Openlnput. 

This module also handles errors. *) 

FROM Token IMPORT token, tokenClass; 

EXPORT QUALIFIED getToken, ungetToken, getTokenCI ass, tokenErrorCheck, 
getTokenErrorCheck, errorFlag, compError, peekTokenCI ass; 

VAR errorFIag:BOOLEAN; (* Set to TRUE when an error occurs. *) 

PROCEDURE getToken(VAR t:token); 

(* Get a token from the input stream. *) 

PROCEDURE ungetToken; 

(* Push a token back on the input stream. Can only unget one at a time. *) 
PROCEDURE getTokenCI ass():tokenClass; 

(* Get a token from the input stream, but just return its class. *) 

PROCEDURE peekTokenCIass();tokenClass; 

(* Get a token from the input stream, unget it, and return its class. *) 

PROCEDURE tokenErrorCheck(tc:tokenCI ass; msg: ARRAY OF CHAR); 

(* Read a token from the input stream and compare its class to tc. If they 
are the same, do nothing. If they are different, write the current line 
to the screen, print the message and unget the token. *) 

PROCEDURE getTokenErrorCheck(VAR t:token; tc:tokenCI ass; msg: ARRAY OF CHAR); 
(* Like tokenErrorCheck, but returns the token as well. *) 

PROCEDURE compError(msg:ARRAY OF CHAR); 

(* Writes the current line and displays msg. Sets errorFlag to TRUE. *) 

END LexAn. 


Start LexAn.MOD 


IMPLEMENTATION MODULE LexAn; 

(* Lexical analyzer for the SIMPL compiler. Uses the routines in LexAnStuff.*) 


{continued) 
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FROM InOut IMPORT EOL; 

FROM Token IMPORT token, tokenCloss; 

FROM MyTerminol IMPORT fatal, WrIteLnStrIng; 

FROM StrlngStuff IMPORT strlngLen; 

FROM Symbol Table IMPORT findKeyword; 

FROM LexAnStuff IMPORT dispatch, enterAII, enterChar, enterEndOfFI Ie, ignore 
enterAlphas, enterDiglts, skipToChar, a IphaNumString, poslnteger, string 
enterWhite, wrlteLlne, getChar, ungetChar; 

VAR tok: token; 

ungotten: BOOLEAN; 

PROCEDURE getToken(VAR t:token); 

BEGIN 

getTok; 
t := tok; 

END getToken; 

PROCEDURE getTok; 

VAR c:CHAR; 

BEGIN 

IF ungotten THEN 

ungotten :■ FALSE; 

ELSE 

dispatch; 

END; 

END getTok; 

PROCEDURE ungetToken; 

BEGIN 

IF ungotten THEN 

fatal("ungetToken: can only unget one token at a time"); 

ELSE 

ungotten :« TRUE; 

END; 

END ungetToken; 

PROCEDURE getTokenCIass():tokenCIass; 

BEGIN 

getTok; 

RETURN tok.cl ass; 

END getTokenCIass; 

PROCEDURE peekTokenCI ass():tokenClass; 

BEGIN 

getTok; 
ungetToken; 

RETURN tok.class; 

END peekTokenCI ass; 

PROCEDURE tokenErrorCheck(tc:tokenCI ass; msg: ARRAY OF CHAR); 

BEGIN 

getTok; 

IF tok.class <> tc THEN 
compError(msg); 

IF tok.class * EndOflnput THEN 

fatal("unexpected end of Input"); 

END; 

ungetToken; 

END; 

END tokenErrorCheck; 

PROCEDURE getTokenErrorCheck(VAR t:token; tc:tokenCI ass; msg: ARRAY OF CKi = 
BEGIN 

tokenErrorCheck(tc, msg); 
t :* tok; 

END getTokenErrorCheck; 

(*** reading procedures ***) 

PROCEDURE I IlegalChar(c:CHAR); 

VAR charstring:ARRAY[0..1] OF CHAR; 

BEGIN 

charstring[0l :« c; (* fake a 1-char string *) 

charstring[1J :■ 0C; 

compError('iI Iegal character*); 

getTok; 


156 BYTE LISTINGS SUPPLEMENT 




February 


END iI IegaIChar; 


PROCEDURE comment(c:CHAR); (* Comments are ignored. They are delimited 

by { and \ *) 

BEGIN 

skipToChar('\'); 
getTok; 

END comment; 


PROCEDURE idOrKeyword(c:CHAR); 

(* Get an alphanumeric string from the input. If we find it in the symbol 

table marked as a keyword, then it's a keyword; findKeyword will have taken 
care of setting tok.class to the right value. Else, it’s an identifier. *) 
BEGIN 

IF NOT a IphaNumString(c, tok.string} THEN 
compError(*identifier too long*); 

END; 

IF NOT findKeyword(tok.string, tok.class) THEN 
tok.class :* Identifier; 

END; 

END idOrKeyword; 

PROCEDURE poslnt(c:CHAR); 

BEGIN 

tok.class :* Int; 

tok.Integer :■ poslnteger(c); 

END poslnt; 

PROCEDURE charProc(c:CHAR); 

(* Read a character, delimited by delim, from the input. Can use 
backslash: \n - newline, \t - tab, anything else literal. *) 

BEGIN 

tok.class :■ Character; 

IF (NOT string(c, tok.string)) OR (stringLen(tok.string) > 1) THEN 
compError(*iI IegaI character constant'); 

END; 

tok.ch :« tok.string[0]; 

END charProc; 


PROCEDURE stringProc(delim:CHAR); 

(* Read a string from the input. If too long, skip to the next delim. *) 
VAR i;CARDINAL; 

c: CHAR; 

BEGIN 

tok.class :■ String; 

IF NOT string(deIim, tok.string) THEN 
compError('string too long’); 
skipToChar(delIm); 

delim :« getChar(); (* get the delimiter *) 

END; 

END stringProc; 


PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 


(*** Reading special characters ***) 

semicolon(c:CHAR);BEGIN tok.class := Semicolon; 

END 

semicolon 

equa1(c:CHAR); 

BEGIN 

tok.c1 ass 

: = 

Equa1; 

END 

equa1; 

comma(c;CHAR); 

BEGIN 

tok.c1 ass 

; s 

Comma; 

END 

comma; 

p1 us(c;CHAR); 

BEGIN 

tok.c1 ass 

; m 

Plus; 

END 

plus; 

minus(c:CHAR); 

BEGIN 

tok.cl ass 

l s 

Minus; 

END 

minus; 

times(c:CHAR); 

BEGIN 

tok.cl ass 

; s 

Times; 

END 

times; 

dividefc:CHARh 

BEGIN 

tok.cl ass 

: = 

Divide; 

END 

divide; 

lparen(c:CHAR); 

BEGIN 

tok.cl ass 

:* 

Lparen; 

END 

1paren; 

rparen(c:CHAR); 

BEGIN 

tok.c1 ass 

: m 

Rparen; 

END 

rparen; 

lbracket(c:CHAR); 

BEGIN 

tok.class 

: rn 

Lbracket; 

END 

lbracket; 

rbracket(c:CHAR); 

BEGIN 

tok.c1 ass 


Rbracket; 

END 

rbracket; 


PROCEDURE greater(c:CHAR); 

BEGIN 

IF getChar() - *«' THEN 

tok.class GreaterEquaI; 

ELSE 

ungetChar; 

tok.class :* Greater; 

[continued) 
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END; 

END greater; 

PROCEDURE I ess(c:CHAR); 

BEGIN 

c :* getChar(); 

IF c - THEN 

tok.class :■ LessEqual; 
ELSIF c - THEN 

tok.class :■ NotEqual; 

ELSE 

ungetChar; 

tok.class :« Less; 

END; 

END less; 

PROCEDURE coI on(c:CHAR); 

BEGIN 

IF getChar() = THEN 

tok.class :* Assignment; 

ELSE 

ungetChar; 

tok.class :« Colon; 

END; 

END colon; 


PROCEDURE p e rIodO r Do t do t(c:CHAR); 
BEGIN 

IF getCharQ = THEN 
tok.class :« DotDot; 

ELSE 

ungetChar; 

tok.class :■ Period; 

END; 

END perlodOrDotdot; 

PROCEDURE endOfInput(c:CHAR); 
BEGIN 

tok.class := EndOflnput; 

END endOfInput; 


(*** Initialization of charTable ***) 


PROCEDURE InitCharTabIe; 

BEGIN 

enterAI 1(1 I IegaI Char); 
enterWhIte(Ignore); 
enterAIphasfidOrKeyword); 
enterDigits(poslnt); 


enterChar(*. 
enterChar(*; 
enterChar(' ; 
enterChar(*( 
enterChar(*) 
enterChar(*, 
enterChar(’ = 
enterChar(*> 
enterChar(*< 
enterChar(’+ 
enterChar( 
enterChar(* * 
enterChar(’/ 
enterChar(* { 
enterCharf*" 
enterChar("* 
enterChar(* [ 
enterChar(* j 


END 


perlodOrDotdot); 
colon); 
semicoIon); 

Iparen); 
rparen); 
comma); 
equaI); 
greater); 

I ess); 
plus); 
minus); 
times); 
divide); 
comment); 
strIngProc); 
charProc); 

I bracket); 
rbracket); 


enterEndOfFiIe(endOfInput); 
initCharTabIe; 

(*** errors ***) 


PROCEDURE compError(msg:ARRAY OF CHAR); 
BEGIN 

wr i teLine; 

Wr iteLnString(msg); 
errorFlag :* TRUE; 
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END compError; 

BEGIN 

ungotten := FALSE; 
errorFlag := FALSE; 
initCharTabIe; 

END LexAn. 


Start Node.DEF 


DEFINITION MODULE Node; 

(* Nodes are what make up the parse tree produced by the SIMPL parser. 
They consist of all data relevant to generating code. 

Changes for part 3: 

1. setNodeType added so ExprParser.typeCoerce could change it. 


*) 


FROM Token IMPORT tokenClass; 

FROM Symbol IMPORT symbol; 

EXPORT QUALIFIED node, nodeClass, NodeClass, emptyNode, nodeEmpty, freeNode, 
makeStmtsNode, makelfNode, makeWhiIeNode, makeReturnNode, 
makeAssignmentNode, makeExprListNode, makeOpNode, makeUnopNode, 
makelntegerNode, makeBooIeanNode, makeSymboI Node, makeCaI I Node, 
makeWriteNode, makeReadNode, makeStringNode, makeCharNode, 
nodeFirst, nodeRest, nodeTest, nodeThen, nodeElse, nodeStmts, nodeRHS, 
nodeLHS, nodeArgs, nodeRoutine, nodeExpr, nodeArg, nodeLeftArg, 
nodeRightArg, nodeOp, nodeSymbol, nodeType, nodelnt, nodeBool, 
nodeNumFormaIs, nodeStrlng, nodeChar, setNodeType, nodeArray, nodeindex, 
makelndexNode; 

TYPE 

NodeClass * (* the different kinds of nodes *) 



(nOp, 
nUnop, 
nBooI, 
nlnt, 
nChar, 
nString, 
nSymboI, 
nlf , 
nWhiIe, 
nReturn, 
nCaI I, 

nAssignment, 
nWrite, nRead, 
nLlst, 
nlndex); 


i* WRITE and READ statements *) 
(* a list of statements or expr 
(★ an array index *) 


node; 

VAR emptyNode: node; 

PROCEDURE nodeClass(n:node):NodeCIass; 

(* Returns the class of node *) 

PROCEDURE nodeEmpty(n:node):B00LEAN; 

(* Returns true if node is the emptyNode *) 

PROCEDURE freeNode(n:node); 

(* Frees the storage associated with n *) 


(*** Node creation ***) 


PROCEDURE makeStmtsNode(first, rest:node):node; 

(* Make a node representing a list of statements *) 

PROCEDURE makeReturnNode(routine:symboI; returnExpr:node):node; 

(* Make a return node. Routine is the routine we are returning from. 

returnExpr is an expression to be returned, for functions; for procedures, 


(continued) 
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It should be the empty node, *) 


PROCEDURE makeCoIINode(name:symboI; actuaIs:node):node; 

PROCEDURE makeWrlteNode(actuaIsinode):node; 

PROCEDURE makeReadNode(actuaIs:node):node; 

(* In all of these, actuals should have been made with makeExprListNode. *) 


PROCEDURE makeIfNode(test, then, e I se mode) mode; 

PROCEDURE makeWhI IeNode(test, stmts:node):node; 

PROCEDURE makeAssIgnmentNode(Ihs, expr:node):node; 

PROCEDURE makeExprLIstNode(fIrst, rest:node):node; 

PROCEDURE makeOpNode(op:tokenClass; leftarg, rIghtarg:node):node; 
PROCEDURE makeUnopNode(op:tokenCI ass; arg:node):node; 

PROCEDURE makeIntegerNode(l:INTEGER):node; 

PROCEDURE makeBooIeanNode(b:BOOLEAN):node; 

PROCEDURE makeSymboINode(Id:symboI)inode; 

PROCEDURE makeStringNode(s:ARRAY OF CHAR):node; 

PROCEDURE makeCharNode(c:CHAR)inode; 

PROCEDURE makeIndexNode(array, Indexinode)inode; 


(*** Accessing parts of nodes **) 

(* many nodes have a type associated with them *) 
PROCEDURE nodeType(ninode):symboI; 

PROCEDURE setNodeType(n:node; typeObject:symbo1); 

(* for constants *) 

PROCEDURE nodelnt(n:node):INTEGER; 

PROCEDURE nodeBool(n:node)iBOOLEAN; 

PROCEDURE nodeChar(ninode)iCHAR; 

PROCEDURE nodeStrIng(n:node; VAR s:ARRAY OF CHAR); 
(* Just truncates is s is too short. *) 

(* for 1 Ists *) 

PROCEDURE nodeFirst(n:node):node; 

PROCEDURE nodeRest(ninode)inode; 

(* for IF statements *) 

PROCEDURE nodeTest(n:node):node; 

PROCEDURE nodeThen(n:node):node; 

PROCEDURE nodeEIse(n:node)inode; 

(* for WHILE statements *) 

PROCEDURE nodeStmts(nmode)inode; 

(* for assignment statements *) 

PROCEDURE nodeRHSfn:node):node; 

PROCEDURE nodeLHS(n:node):node; 

(* for calls *) 

PROCEDURE nodeArgs(nmode) inode; 

PROCEDURE nodeRoutine(n:node):symboI; 

(* for RETURN statements *) 

PROCEDURE nodeExpr(mnode) inode; 

PROCEDURE nodeNumFormaIs(n:node):CARDINAL; 

(* for ops and unops *) 

PROCEDURE nodeArg(n:node):node; 

PROCEDURE nodeLeftArg(n:node):node; 

PROCEDURE nodeRightArg(n:node):node; 

PROCEDURE nodeOp(n:node):tokenClass; 


(* also for WHILE statements *) 


(* right-hand side *) 
(* left-hand side *) 


(* for symbols *) 

PROCEDURE nodeSymboI(n:node):symboI; 

(* for array indexing *) 

PROCEDURE nodeArray(n mode) mode; 
PROCEDURE nodeIndex(nmode) mode; 


END Node. 


Start Node.MOD 
IMPLEMENTATION MODULE Node; 
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(* Procedures for constructing and manipulating the nodes of the parse tree. 

Most type-checking is done here. *) 

FROM Token IMPORT tokenClass, stringType, isRelation; 

FROM Symbol IMPORT symbol, Class, emptySymbol, numFormals, symbolList, 
sISymbol, slEmpty, sINext; 

IMPORT Symbol; 

FROM SymboI Tab Ie IMPORT tUnknown, tString, tlnteger, tChar, tBoolean; 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM TypeChecker IMPORT typeCompatibIe, opAppropriate, callCheck, unopCheck, 
readCheck, writeCheck, binopCheck, returnCheck, assignCheck, baseType; 

FROM MyTerminal IMPORT WriteString, fatal; 

FROM StringStuff IMPORT stringCopy; 

TYPE 

node = POINTER TO nodeRec; 
nodeRec = RECORD 

type: symbol; 

CASE cI ass:NodeCIass OF 

nOp: op; tokenClass; leftArg, rightArg: node; 

nUnop: unop: tokenClass; arg: node; 

nBool: bool: BOOLEAN; 

nlnt; int: INTEGER; 

nChar: ch: CHAR; 

nString: string:stringType; 

nSymbol: sym: symbol; 

nlf: test, then, else: node; 

nWhile: wtest, stmts: node; 

nAssignment: LHS, RHS:node; 

nCall, nWrite, nRead: routine:symboI; args:node; 
nReturn: nFormaIs:CARDINAL; expr:node; 
nList: first, rest:node; 
nlndex: array, index:node; 

END; 

END; 


PROCEDURE nodeCI ass(n:node):NodeClass; 

BEGIN 

RETURN n^.class; 

END nodeCI ass; 

PROCEDURE nodeEmpty(n:node):BOOLEAN; 

BEGIN 

RETURN n *= emptyNode; 

END nodeEmpty; 

PROCEDURE freeNode(n:node); 

BEGIN 

IF n <> emptyNode THEN 

WITH n~ DO CASE class OF 

nlnt, nBool, nSymbol, nString, nChar: (* do nothing *); 
| nOp: freeNode(IeftArg); 

freeNodefrightArg); 
nUnop: freeNode(arg); 

| nlf: freeNodeftest); 

freeNode(then); 
freeNode(eIse); 

| nWhile: freeNode(wtest); 

freeNode(stmts); 

| nAssignment: freeNode(LHS); 

freeNode(RHS); 

nCall, nRead, nWrite: freeNode(args); 
nReturn:freeNodefexpr); 
nList: freeNode(f1rst); 

freeNodefrest); 

| nlndex: freeNode(array); 

f reeNode(index); 

ELSE 

WriteString("freeNode: unknown node type"); 

END; END; 

DISPOSE(n); (* , n A .class); *) 

END; 

END freeNode; 
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(*** node creation ***) 

PROCEDURE makeStmtsNode(fIrst, restinode);node; 

VAR n:node; 

BEGIN 

n :■ newNode(nLIst); 
n*.first :« first; 
n^.rest :■ rest; 

RETURN n; 

END makeStmtsNode; 

PROCEDURE makeExprLIstNode(f1 rst, rest:node);node; 

VAR ninode; 

BEGIN 

n := newNode(nList); 
n*.first :* first; 
n^.rest :■* rest; 

RETURN n; 

END makeExprListNode; 

PROCEDURE makelfNode(test, then, eIse:node):node; 

VAR ninode; 

BEGIN 

n := newNode(nIf); 
n^.test ;= test; 
n^.then i* then; 
n^.else i» else; 

RETURN n; 

END makelfNode; 

PROCEDURE makeWhlIeNode(test, stmtsinode)inode; 

VAR ninode; 

BEGIN 

n := newNode(nWhI Ie); 
n^.wtest :* test; 
n*.stmts i■ stmts; 

RETURN n; 

END makeWhI IeNode; 

PROCEDURE makeReturnNode(routIneisymbol; returnExprinode)inode; 

VAR ninode; 

BEGIN 

n i« newNode(nReturn); 
n^.expr i« returnExpr; 

IF returnCheck(routIne, returnExpr) THEN 
n^.nFormals := sIzeFormaIs(routlne); 

END; 

RETURN n; 

END makeReturnNode; 

PROCEDURE sizeFormaIs(routine:symboI)iCARDINAL; 

(* Returns the number of words occupied by formals. Before this was just 
the number of formals, but now each open array pnram adds 2 to the count 
(For its bounds.) *) 

VAR form I Ist:symboIList; 
sum:CARDINAL; 
tisymboI; 

BEGIN 

formlist i« SymboI.forma Is(routine); 
sum ;« 0; 

WHILE NOT slEmpty(formlist) DO 

t i= SymboI.type(sISymboI(formIist)); 

IF (Symbol.class(t) * ArrayType) AND Symbol.open(t) THEN 
INC(sum, 3); 

ELSE 

INC(sum); 

END; 

formlist i= sI Next(form Iist); 

END; 

RETURN sum; 

END sizeFormals; 

PROCEDURE makeAssignmentNode(Ihs, exprinode)inode: 

VAR ninode; 

BEGIN 

n i* newNode(nAssignment); 
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n^.LHS := Ihs; 

n^.RHS := expr; 

assignCheck(Ihs, expr); 

RETURN n; 

END makeAssignmentNode; 

PROCEDURE makeOpNode(op:tokenCIass; leftarg, rightarg:node):node; 
VAR ninode; 

typeOK:BOOLEAN; 

BEGIN 

n := newNode(nOp); 
n^.op := op; 
n^.leftArg := leftarg; 
n^.rightArg :« rightarg; 

typeOK := binopCheck(op, leftarg, rightarg); 

IF isReI ation(op) THEN 
n^.type :* tBoolean; 

ELSIF typeOK THEN 

n^.type Ieftarg*.type; 

ELSE 

n^.type := tUnknown; 

END; 

RETURN n; 

END makeOpNode; 

PROCEDURE makeUnopNode(op:tokenClass; arg:node)inode; 

VAR ninode; 

BEGIN 

n i= newNode(nUnop); 
n^.unop i* op; 
n^.arg ;= arg; 

IF unopCheck(op, arg) THEN 
n^.type ;■ arg*.type; 

ELSE 

n*.type :* tUnknown; 

END; 

RETURN n; 

END makeUnopNode; 

PROCEDURE makeIntegerNode(i;INTEGER)inode; 

VAR n;node; 

BEGIN 

n !« newNode(nInt); 
n*.type := tlnteger; 
n*.int := I; 

RETURN n; 

END makelntegerNode; 

PROCEDURE makeBooIeanNode(biBOOLEAN)inode; 

VAR n;node; 

BEGIN 

n i* newNode(nBooI); 
n*.type i= tBoolean; 
n*.bool i*= b; 

RETURN n; 

END makeBooIeanNode; 

PROCEDURE makeCharNode(ciCHAR)inode; 

VAR n;node; 

BEGIN 

n ;« newNode(nChar); 
n*.type tChar; 
n*.ch i* c; 

RETURN n; 

END makeCharNode; 

PROCEDURE makeSymboINode(s:symboI)inode; 

VAR ninode; 

BEGIN 

n i* newNode(nSymboI); 
n*.type :« SymboI.type(s); 
n*.sym :■ s; 

RETURN n; 

END makeSymboINode; 


( continued ) 
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PROCEDURE makeCalINode(name:symboI; actuaI 8mode)inode; 
VAR ninode; 

BEGIN 

n newNode(nCaI I); 

WITH n* DO 

routine :■ name; 

args actuals; 

type :■ SymboI.type(name); 

caIICheck(routine, args); 

END; 

RETURN n; 

END makeCalINode; 

PROCEDURE makeWrIt©Node(actuals:node):node; 

VAR ninode; 

BEGIN 

wr I teCheck(actuaIs); 
n ;» newNode(nWrIte); 
n~.routine :* emptySymbol; 
n^.args actuals; 

RETURN n; 

END makeWrIteNode; 

PROCEDURE makeReadNode(actuaIs:node):node; 

VAR ninode; 

BEGIN 

readCheck(actuaIs); 
n :■ newNode(nRead); 
n*.routine :« emptySymbol; 
n^.args :■ actuals; 

RETURN n; 

END makeReadNode; 

PROCEDURE makeStringNode(s:ARRAY OF CHAR):node; 

VAR ninode; 

BEGIN 

n ;■ newNode(nStrIng); 
strIngCopy(n*.strIng, s); 
n^.type i* tStrlng; 

RETURN n; 

END makeStrIngNode; 

PROCEDURE makeIndexNode(array, Indexmode) inode; 

VAR ninode; 

BEGIN 

n !■ newNode(nlndex); 

IF SymboI.empty(nodeType(array)) THEN 
n^.type i« emptySymbol; 

ELSE 

n^.type i* baseType(SymboI.type(nodeType(array))); 

END; 

n^.array i- array; 
n^.index i* index; 

RETURN n; 

END makelndexNode; 

PROCEDURE newNode(nciNodeCI ass)inode; 

VAR ninode; 

BEGIN 

NEW(n); (* nc); *) 
n^.class ;■ nc; 
n^.type i* tUnknown; 

RETURN n; 

END newNode; 


(*** node access ***) 

PROCEDURE nodelnt(ninode)iINTEGER; 

BEGIN 

nodeCIassCheck('nodeInt•, n, nlnt); 

RETURN n^.int; 

END nodelnt; 

PROCEDURE nodeBool(ninode)iBOOLEAN; 

BEGIN 

nodeClassCheck('nodeBool*, n, nBool); 
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RETURN n^.bool; 

END nodeBooI; 

PROCEDURE nodeChar(n:node):CHAR; 

BEGIN 

nodeCIassCheck('nodeChar', n, nChar); 

RETURN n^.ch; 

END nodeChar; 

PROCEDURE nodeStrlng(ninode; VAR s:ARRAY OF CHAR); 

BEGIN 

nodeCIassCheck('nodeString', n, nString); 
stringCopy(s, n~.string); 

END nodeStrlng; 

PROCEDURE nodeFirst(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeFirst', n, nList); 

RETURN n".first; 

END nodeFirst; 

PROCEDURE nodeRest(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeRest*, n, nList); 

RETURN n~.rest; 

END nodeRest; 

PROCEDURE nodeTest(n:node):node; 

BEGIN 

IF n^.class = nlf THEN 
RETURN n*.test; 

ELSIF n".class « nWhile THEN 
RETURN n^.wtest; 

ELSE 

nodeCIassError('nodeTest'); 

RETURN emptyNode; 

END; 

END nodeTest; 

PROCEDURE nodeThen(n:node):node; 

BEGIN 

nodeCIassCheck('nodeThen', n, nlf); 

RETURN n*.then; 

END nodeThen; 

PROCEDURE nodeEIse(n:node);node; 

BEGIN 

nodeCIassCheck('nodeEIse', n, nlf); 

RETURN n^.else; 

END nodeEIse; 

PROCEDURE nodeStmts(n:node)inode; 

BEGIN 

nodeClassCheck('nodeStmts*, n, nWhile); 

RETURN n".stmts; 

END nodeStmts; 

PROCEDURE nodeRHS(ninode)inode; 

BEGIN 

nodeCIassCheck('nodeRHS', n, nAssignment); 

RETURN n^.RHS; 

END nodeRHS; 

PROCEDURE nodeLHS(ninode)inode; 

BEGIN 

nodeClassCheck('nodeLHS', n, nAssignment); 

RETURN n^.LHS; 

END nodeLHS; 

PROCEDURE nodeArgs(nmode) inode; 

BEGIN 

WITH n* DO 

IF (class ■ nCall) OR (class » nRead) OR (class = nWrite) THEN 
RETURN args; 

ELSE 

(continued) 
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nodeClassError('nodeArgs’); 

END; 

END; 

END nodeArgs; 

PROCEDURE nodeRoutIne(nmode)isymbol; 

BEGIN 

nodeCIassCheck(*nodeRoutine' , n, nCaII); 
RETURN n*.routine; 

END nodeRoutIne; 

PROCEDURE nodeExpr(n:node):node; 

BEGIN 

nodeClassCheck(*nodeExpr', n, nReturn); 
RETURN n^.expr; 

END nodeExpr; 

PROCEDURE nodeArg(n:node)mode; 

BEGIN 

nodeCIassCheck(*nodeArg', n, nUnop); 
RETURN n^.arg; 

END nodeArg; 

PROCEDURE nodeLeftArg(n:node)inode; 

BEGIN 

nodeCIassCheck('nodeLeftArg*, n, nOp); 
RETURN n".leftArg; 

END nodeLeftArg; 

PROCEDURE nodeRightArg(n:node):node; 

BEGIN 

nodeClassCheck('nodeRightArg’, n, nOp); 
RETURN n*.rIghtArg; 

END nodeRightArg; 

PROCEDURE nodeOp(n;node):tokenCIass; 

BEGIN 

IF n".class - nOp THEN 
RETURN n^.op; 

ELSIF n^.class * nUnop THEN 
RETURN n^.unop; 

ELSE 

nodeCIassError('nodeOp'); 

RETURN Plus; 

END; 

END nodeOp; 

PROCEDURE nodeSymboI(n:node):symboI; 

BEGIN 

nodeCIassCheck('nodeSymboI', n, nSymbol); 
RETURN n^.sym; 

END nodeSymbol; 

PROCEDURE nodeArray(nmode):node; 

BEGIN 

nodeCIassCheck("nodeArray", n, nlndex); 
RETURN n".array; 

END nodeArray; 

PROCEDURE nodeIndex(n:node):node; 

BEGIN 

nodeClassCheck("nodeIndex", n, nlndex); 
RETURN n".Index; 

END nodeindex; 


PROCEDURE nodeNumFormaIs(n mode):CARDINAL; 

BEGIN 

nodeClassCheck('nodeNumFormals*, n, nReturn); 
RETURN n^.nFormals; 

END nodeNumFormaIs; 

PROCEDURE nodeType(n:node)rsymbol; 

BEGIN 

RETURN n*.type; 

END nodeType; 
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PROCEDURE setNodeType(ninode; typeObjectisymboI); 

BEGIN 

n^.type :* typeObject; 

END setNodeType; 

(*** other ***) 

PROCEDURE nodeCIassCheck(s:ARRAY OF CHAR; ninode; nciNodeCIass); 
BEGIN 

IF n^.class <> no THEN 
nodeCIassError(s); 

END; 

END nodeCIassCheck; 

PROCEDURE nodeCIassError(s:ARRAY OF CHAR); 

BEGIN 

Wr i teStrIng(s); 

fatal(": node of wrong type"); 

END nodeCIassError; 


BEGIN 

emptyNode :* NIL; 
END Node. 


Start Parser.DEF 


DEFINITION MODULE Parser; 

(* This Is the bulk of the SIMPL parser. It covers most of the language. 
For routines (procedures and functions) see Routines. 

For expressions, see ExprParser. 

Syntax handled by this module: 

/ 

<program> PROGRAM <id>; <vars> <routines> <block> . 

<types> <empty> | TYPE <typelist> 

<typelist> <tvpedecl> | <typedecl> <typelist> 

<typedecl> <id> * <type> ; 

<type> <id> | ARRAY [ <int> .. <int>] OF <type> 

<vars> ::= <empty> | VAR <varlist> 

<varlist> <decl> | <decl> <varlist> 

<decl> <IdI Ist> : <type> ; 

<idlist> <id> | <id> . <1dI Ist> 

<block> BEGIN <stmts> END 

<stmts> ::* <empty> | <stmt> ; <stmts> 

<stmt> <whlle> | <if> | <return> | <assign> | <caI I> 

<while> WHILE <expr> DO <stmts> END 

<if> ::«= IF <e I s I f> END 

<eIsif> <expr> THEN <stmts> <else> 

<else> <empty> | ELSIF <eIsIf> | ELSE <stmts> 

<return> RETURN | RETURN <expr> 

<assign> <idOrindex> <expr> 

<caI I> <id> <actuals> 

<actuals> <empty> | ( <exprlist> ) 

<exprlist> <expr> | <expr> , <exprllst> 

*) 

FROM Symbol IMPORT symbol; 

FROM Node IMPORT node; 

FROM Token IMPORT tokenList; 

EXPORT QUALIFIED program, types, vars, Idlist, block, actuals; 

PROCEDURE program; 

(* Parse the entire program *) 


{continued) 
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PROCEDURE types(routineName:symbol); 

(* Parse type declarations. See below for explanation of routineName. *) 
PROCEDURE vars(routineName:symboI); 

(* Parse variable declarations. RoutineName is the name of the routine 
currently being compiled; if these are global variables, it should be 
the name of the program. *) 

PROCEDURE Idlist():tokenLIst; 

(* Parse a list of identifiers *) 

PROCEDURE block(routine:symboI)inode; 

(* Parse a block of code. Routine is the routine currently being compiled. *) 
PROCEDURE actuaIs()mode; 

(* Parse a list of actual parameters, l.e. a list of expressions. *) 


END Parser. 


Start Parser.MOD 


IMPLEMENTATION MODULE Parser; 

(* Most of the parser for the SIMPL compiler. It is a top-down, recursive 
descent parser. 

Changes for part 3: 

1. Type declarations and arrays are parsed. 

2. Type objects used instead of the old typeType. 


*) 

FROM Token IMPORT token, tokenClass, emptyTokenList, stringType, 

tIToken, tINext, tIEmpty, addToTokenList, tokenList, freeTokenList; 

FROM LexAn IMPORT getToken, getTokenCI ass, peekTokenCI ass, compError, 
ungetToken, tokenErrorCheck, getTokenErrorCheck; 

FROM Symbol IMPORT symbol, emptySymbol, isType, Class; 

IMPORT Symbol; 

FROM SymbolTable IMPORT enterSymbol, enterLocal, enterFormal, findSymbol, 
currentLexLeveI, tUnknown, enterArrayType; 

FROM Node IMPORT node, emptyNode, makeStmtsNode, makelfNode, makeWhiIeNode, 
makeReturnNode, makeAssignmentNode, makeExprListNode, 
makeCaI I Node, makcReadNode, makeWriteNode, nodeType, makeSymboI Node; 

FROM CodeGon IMPORT genBleck, genGlobal; 

FROM CodeWrite IMPORT writeStringBranch, writeHalt, writeRoutIneLabeI, 
wr iteStrings; 

FROM TypeChecker IMPORT boolCheck, assignable; 

FROM ExprParser IMPORT expr, idOrlndex; 

FROM Routines IMPORT routines; 

FROM MyTerminal IMPORT fatal; 

VAR programName:symboI; 


(* <program> :PROGRAM <id>; <types> <vars> <routines> <block> . *) 
PROCEDURE program; 

VAR t:token; 

ninode; 

BEGIN 

tokenErrorCheck(Program, ’keyword "PROGRAM" expected*); 
getTokenErrorCheck(t, Identifier, ’name of program expected'); 

IF t.class <> Identifier THEN 

t.string := "???"; (* if the program name isn't given, make one up * 

END; 

programName := enterSymboI(t.string, Proc, tUnknown); 
wr iteStringBranch(t.string); 

tokenErrorCheck(SemicoI on, 'semicolon expected’); 
types(emptySymboI); 
vars(emptySymboI); 
routines; 

writeRoutineLabeI(programName); 
genBlock(block(programName)); 
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tokenErrorCheck(Period, 'period expected*); 
tokenErrorCheck(EndOfInput, ’end of input expected*); 
writeHaIt; 
wr iteStrings; 

END program; 

(*** type declarations ***) 

(* <types> <empty> | TYPE <typelist> *) 

PROCEDURE types(routineName:symboI); 

BEGIN 

IF getTokenCIass() = Type THEN 
typelist(routineName); 

ELSE 

ungetToken; 

END; 

END types; 

(* <typelist> <typedecl> | <typedecl> <typelist> *) 

PROCEDURE type Iist(rout 1neName:symboI); 

BEGIN 

typedecI(routineName); 

IF peekTokenCIass() = Identifier THEN 
typelist(routineName); 

END; 

END typelist; 

(* <typedecl> :<id> = <type> ; *) 

PROCEDURE typedecI(routineName:symboI); 

VAR typeToken:token; 

typeObject;symboI; 

BEGIN 

getToken(typeToken); 

IF typeToken.cI ass <> Identifier THEN 
compError(* identifier expected’); 
ungetToken; 

typeToken.string :* *???*; (* make up a type name *) 

END; 

tokenErrorCheck(EquaI, ’equal sign expected’); 
typeObject :« type(); 

IF NOT Symbol.empty(typeObject) THEN 

IF Symbol.class(typeObject) * ArrayType THEN 

hand IeArray Type(typeToken.string, typeObject); 

ELSIF SymboI.cIass(typeObject) = ScalarType THEN 

typeObject := enterSymboI(typeToken.string, Sea IarType,typeObject); 

ELSE 

(* do nothing—error caught in type() *) 

END; 

END; 

tokenErrorCheck(SemicoIon, "semicolon expected"); 

END typedecI; 

PROCEDURE hand IeArrayType(VAR s:stringType; typeObject:symboI); 

(* If the array type hasn't been named, name it and insert it; else, 
copy it and give the copy the new name. *) 

VAR typeName:stringType; 

BEGIN 

IF SymboI.anonymous(typeObject) THEN 
enterArrayType(s, typeObject); 

ELSE 

enterArrayType(s, SymboI.copyArrayType(typeObject)); 

END; 

END hand IeArrayType; 

(* <type> <id> | ARRAY [ Int .. Int ] OF <type> *) 

PROCEDURE type():symboI; 

VAR t:token; 

typeSymbol;symboI; 

BEGIN 

getToken(t); 

IF t.class = Identifier THEN 

typeSymbol :■ fIndSymboI(t.string); 

IF isType(typeSymbol) THEN 
RETURN typeSymbol; 

ELSE 

(continued) 
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compError('not a type*); 

RETURN tUnknown; 

END; 

ELSIF t.class ■ Array THEN 

tokenErrorCheck(Lbracket, "left bracket expected"); 
RETURN type1(); 

ELSE 

compError("Identifler or ARRAY expected"); 
ungetToken; 

RETURN tUnknown; 

END; 

END type; 


PROCEDURE typel():symboI; 

VAR t:token; 

IowBound, highBound, temp;INTEGER; 
BEGIN 


lowBound :■ getBound(); 

tokenEr rorCheck(DotDot, *two dots expected*); 
highBound :« getBound(); 

IF lowBound > highBound THEN 

compError("lowBound > highBound"); 
temp :■ lowBound; 
lowBound :« highBound; 
highBound :■ temp; 

END; 

getToken(t); 

IF t.cl ass « Comma THEN 

RETURN Symbol.newArrayType(type1(), lowBound, highBound, FALSE, 

currentLexLeveI ()); 

ELSIF t.class « Rbracket THEN 

tokenErrorCheck(Of, *0F expected*); 

RETURN Symbol.newArrayType(type(), lowBound, highBound, FALSE, 
currentLexLeveI()); 

ELSE ' 


compError("Comma or right bracket expected"); 

ungetToken; 

RETURN tUnknown; 

END; 

END typel; 


PROCEDURE getBound():INTEGER; 

(* Reads In an integer, possibly negative. *) 

VAR t;token; 

BEGIN 

getToken(t); 

IF t.class * Int THEN 
RETURN t. integer; 

ELSIF t.class » Minus THEN 

getTokenErrorCheck(t, Int, "integer expected"); 
RETURN -t.integer; 

ELSE 

ungetToken; 

compError("integer expected"); 

RETURN 0; 

END; 

END getBound; 


(*** variable declarations ***) 

(* <vars> <empty> | VAR <varlist> *) 

PROCEDURE vars(routineName:symboI); 

3EGIN 

IF getTokenCIass() = Var THEN 
varIist(routineName); 

ELSE 

ungetToken; 

END; 

iND vars; 

(* <varIist> ;<decl> | <decl> <varlist> 

We can recognize the end of a varlist by seeing if the next token is an 
identifier. An Id indicates the varlist continues. If it didn’t we’d 
see a keyword: either Begin, Procedure or Function. *) 

5 R0CEDURE varIist(routineName:symboI); 

3EGIN 
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dec I(routineName); 

IF peekTokenCIass() = Identifier THEN 
varIist(routineName); 

END; 

END varIist; 

(* <decl> ::= <IdIist> : <type> ; 

Declarations. All the work of putting information about the variables into 
the symbol table is done here. *) 

PROCEDURE dec I(routineName:symboI); 

VAR tl, tokenp:tokenList; 
t, id:token; 

typeSymbol:symboI; 

BEGIN 

tl := idl1st(); 

tokenErrorCheck(CoIon, ’colon expected*); 
typeSymbol := type(); 

tokenErrorCheck(SemicoIon, ’semicolon expected’); 
tokenp := tI; 

(* Enter the variables into the symbol table. For globals, also generate 
the variables. *) 

WHILE NOT tlEmpty(tokenp) DO 
tIToken(tokenp, id); 

IF currentLexLeveI() » 0 THEN 

genGlobal(enterSymbol(id.string, Global, typeSymbol)); 

ELSE 

enterLocaI(id.string, typeSymbol, routineName); 

END; 

tokenp :*= 11 Next (tokenp) ; 

END; 

freeTokenList(tI); 

END dec I; 

(* <idlist> <id> | <id> , <idIist> *) 

PROCEDURE idlist():tokenList; 

VAR t: token; 

BEGIN 

getTokenErrorCheck(t, Identifier, ’identifier expected’); 

IF getTokenClass() <> Comma THEN (* this is the end of the Idli31 *) 
ungetToken; 

IF t.class = Identifier THEN 

RETURN addToTokenList(t, emptyTokenList); 

ELSE 

RETURN emptyTokenList; 

END; 

(* we saw a comma, so there’s more *) 

ELSIF t.class = Identifier THEN 

RETURN addToTokenLIst(t, idlist()); 

ELSE 

RETURN idlist(); 

END; 

END idlist; 


(*** blocks and statements ***) 

(* <block> ;BEGIN <stmts> END *) 

PROCEDURE bIock(routine:symboI);node; 

VAR ninode; 

BEGIN 

tokenErrorCheck(Begin, ’BEGIN expected’); 
n :* stmts(routine); 

tokenErrorCheck(End, ’"END" expected*); 

RETURN n; 

END block; 

(* <stmts> <empty> | <stmt> ; <stmts> 

We can recognize an empty <stmts> by seeing if the next token is ELSE, 
ELSIF or END. *) 

PROCEDURE stmts(routineisymbol):node; 

VAR ninode; 

tcitokenCI ass; 

BEGIN 

tc peekTokenClass(); 

IF (tc - Else) OR (tc - Elsif) OR (tc - End) THEN 
RETURN emptyNode; 


{continued) 
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ELSE 

n :■ stmt(routIne); 

tokenErrorCheck(Semlcolon, 'a semicolon must end a statement*); 
RETURN makeStmtsNode(n, stmts(routIne)); 

END; 

END stmts; 

(* <stmt> <whfle> I <!f> | <return> | <assign> | <caI I> | 

<wrlte> I <read> *) 

PROCEDURE stmt(routine:symbol):node; 

VAR t:token; 

BEGIN 

getToken(t); 

CASE t.cl ass OF 

If: RETURN IfStmt(rout Ine); 

While: RETURN whlleStmt(routIne) ; 

Return: RETURN returnStmt(routine); 

IF SymboI.equaI(routine, programName) THEN 

compError("can*t return from main program"); 

ELSE 

RETURN makeReturnNode(routIne, expr()); 

END; 

Write: RETURN makeWrlteNode(actuaIs()); 

Read: RETURN makeReadNode(readActuaIs()); 

Identifier: RETURN assignOrCaI I Stmt(t); 

ELSE 

compError(*iI IegaI statement type*); 

RETURN emptyNode; 

END; 

END stmt; 


(* <if> IF <eIsif> END *) 

PROCEDURE IfStmt(routine:symboI):node; 

VAR n:node; 

BEGIN 

n :** elsif (rout ine); 

tokenErrorCheck(End, *END expected*); 

RETURN n; 

END ifStmt; 

(* <elsif> <expr> THEN <stmts> <else> *) 

PROCEDURE eIsif(rout Ine:symboI):node; 

VAR nl, n2:node; 

BEGIN 

nl :* expr(); 
boolCheck(nl); 

tokenErrorCheck(Then, *THEN expected*); 
n2 :- stmts(routine) ; 

RETURN makeIfNode(n1, n2, eIse(routine)); 

END elsif; 

(* <else> ::=* <empty> | ELSIF <e I s i f > | ELSE <stmts> 

We can tell an <else> is empty by seeing if the next token is END. *) 
PROCEDURE eIse(routine:symboI):node; 

BEGIN 

CASE getTokenCIass() OF 
End: ungetToken; 

RETURN emptyNode; 

Elsif: RETURN makeStmtsNode(eIsif(routine), emptyNode); 

Else: RETURN stmts(routine); 

ELSE 

compError(’END, ELSIF or ELSE expected’); 
ungetToken; 

RETURN emptyNode; 

END; 

END else; 

(* <while> WHILE <expr> DO <stmts> END *) 

PROCEDURE whI IeStmt(routine:symboI):node; 

VAR n:node; 

BEGIN 

n :« expr() ; 
booICheck(n); 

tokenErrorCheck(Do, *D0 expected*); 
n :«= makeWhiIeNode(n, stmts (rout i ne) ) ; 
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tokenErrorCheck(End, ’END expected’); 

RETURN n; 

END whileStmt; 

(* <return> RETURN | RETURN <expr> *) 

PROCEDURE returnStmt(routinersymboI)mode; 

BEGIN 

IF Symbol.equal(routine, programName) THEN 

compError("can*t return from main program"); 

END; 

IF peekTokenCIass() * Semicolon THEN 

RETURN makeReturnNode(routine, emptyNode); 

ELSE 

RETURN makeReturnNode(routine, expr()); 

END; 

END returnStmt; 

(* We can’t distinguish an assignment from a call based on the first token 
of the statement, since in both cases it’s an identifier. The next token, 
though, will distinguish: it’s an assignment sign or a left bracket 
for an assignment. *) 

PROCEDURE assignOrCalIStmt(t:token)mode; 

VAR tc:tokenCIass; 

BEGIN 

c := peekTokenClass(); 

IF (tc = Assignment) OR (tc - Lbracket) THEN 
RETURN assignStmt(t); 

ELSE 

RETURN calIStmt(t); 

END; 

END assignOrCaIIStmt; 

(* <asslgn> <id0rlndex> :■ <expr> *) 

PROCEDURE assignStmt(varName:token)mode; 

VAR nmode; 

BEGIN 

n :« id0rlndex(findSymbol(varName.string)); 

IF NOT assignable(n) THEN 

compError(’cannot assign to this*); 
tokenErrorCheck(Assignment, expected"); 

RETURN expr(); (* consume the expression anyway *) 

ELSE 

tokenErrorCheck(Assignment, expected"); 

RETURN makeAss1gnmentNode(n, expr()); 

END; 

END assignStmt; 

(* <caI I> <id> <actuals> *) 

PROCEDURE cal I Stmt(rout 1neName:token)mode; 

VAR procrsymboI; 

BEGIN 

proc :« findSymbol(routIneName.string); 

IF NOT Symbol.classEqual(proc, Proc) THEN 

compError('on Iy procedures can be used in a call statement’); 

RETURN actualsQ; (* consume the actuals anyway *) 

ELSE 

RETURN makeCaIINode(proc, actuals()); 

END; 

END calIStmt; 

(* <actuals> <empty> | ( <exprlist> ) 

We can recognize an empty <actuals> by seeing if the next character is a 
left parenthesis. *) 

PROCEDURE actuals():node; 

VAR nmode; 

BEGIN 

IF getTokenClass() - Lparen THEN 
n :■ exprIIst(); 

tokenErrorCheck(Rparen, ’right paren expected*); 

RETURN n; 

ELSE 

ungetToken; 

RETURN emptyNode; 

END; 

END actuals; 


( continued) 
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(* <expr11st> <expr> | <expr> , <exprlist> 

Exprlist always returns an nUst node, even if there's only one expr. *) 
PROCEDURE exprI 1st():node; 

VAR n:node; 

BEGIN 

n :* expr() ; 

IF getTokenCIass() - Comma THEN 

RETURN makeExprListNode(n, exprllst()); 

ELSE 

ungetToken; 

RETURN makeExprListNode(n, emptyNode); 

END; 

END exprIist; 

(* These two procedures are for the args to READ *) 

PROCEDURE readActuaIs():node; 

VAR n:node; 

BEGIN 

IF getTokenCIass() - Lparen THEN 
n :■ readExprI Ist(); 

tokenErrorCheck(Rparen, 'right paren expected*); 

RETURN n; 

ELSE 

ungetToken; 

RETURN emptyNode; 

END; 

END readActuals; 


PROCEDURE readExprI Ist():node; 

VAR t;token; 

n:node; 

BEGIN 

getTokenErrorCheck(t, Identifier, "identifier expected"); 
n :* id0rlndex(findSymbol(t.string)); 

IF getTokenClass() = Comma THEN 

RETURN makeExprListNode(n, readExprIist()); 

ELSE 

ungetToken; 

RETURN makeExprListNode(n, emptyNode); 

END; 

END readExprlist; 

BEGIN 

END Parser. 


Start Routines.DEF 


DEFINITION MODULE Routines; 

(* The part of the parser that deals with procedures and functions. 
Syntax: 

<routines> ::= <empty> | <proc> <routines> | <func> <routines> 
<proc> procedure <id> <formals> ; <vars> <block> ; 

<func> ::= function <id> <formals> : <id> ; <vars> <block> ; 

<formaIs> <empty> | ( <formlist> ) 

<formlist> :<formdecl> | <formdecl> ; <formlist> 

<formdecI> :<idIist> : <mode> <typeld> 

<mode> ::= <empty> | IN | OUT | IN OUT 
<typeld> <id> | ARRAY OF <id> 

Changes for part 3: 

1. Modes handled. 

2. Open array parameters handled. 


*) 

EXPORT QUALIFIED routines; 
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PROCEDURE routines; 
END Routines. 


Start Routines.MOD 


IMPLEMENTATION MODULE Routines; 

(* The part of the parser that handles procedures and functions. 

There are basically two things that have to be done: the routine 
declarations have to be processed to yield symbol table entries, and 
the code for the routine bodies has to be generated. The lists of 
formal parameters (arguments) and locals variables are placed in the 
appropriate slots in the symbol table entry for the routine. For functions, 
the return type of the function is put in the type slot of the symbol; for 
procedures, this slot is left undefined. An offset from the stack pointer 
is given to each local and formal. The initial offsets assume the 
following stack conventions: 


FP-> 


arg 1 
arg 2 

oidFP 

SP 

return 
loc 1 
loc 2 


stack grows down 
towards low memory 


The list of formals must be backwards to match the argument conventions. 

The order of the locals doesn’t matter, but it’s also backwards. 

We generate code as if for a block, with two exceptions: at the beginning, 
we have to push enough words to move the stack pointer past the local 
storage area; while we are at it, we initialize the words to 0. At the 
end, we generate a return, in case the user didn’t. For procedures, it 
is okay to return by falling off the end. For functions, something has to 
be returned explicitly; it is an error to fall through. 

Changes for part 3: 

1. Formal parameter modes handled. 

2. Arrays handled. Always passed by reference; starting address passed. 

3. Open array params handled. The bounds get offsets just below the 
starting address. 


*) 

FROM Token IMPORT token, tokenClass, 

tokenList, tIEmpty, 11 Next, tIToken, freeTokenList; 

FROM LexAn IMPORT getToken, getTokenCI ass, ungetToken, tokenErrorCheck, 
getTokenErrorCheck, compError, peekTokenCI ass; 

FROM Symbol IMPORT symbol, isType, symbol List, si Next, si Symbol, si Empty, 
Class, numLocals, modeType, newArrayType; 

IMPORT Symbol; 

FROM SymbolTable IMPORT enterSymbol, enterFormal, beginRoutine, endRoutine, 
tUnknown, findSymbol, currentLexLeveI; 

FROM CodeGen IMPORT genBlock, genLocals; 

FROM CodeWrite IMPORT writelnt, writeFReturn, writeReturn, writeRoutIneLabeI, 
writeStrings; 

FROM Parser IMPORT vars, types, idlist, block; 

FROM Node IMPORT node; 


CONST 

In 11la ILocalOffset - -1; (* offsets, In words, from the FP *) 

inltlalFormalOffset ■ 3; 


(* <routlnes> :<empty> | <proc> <routines> | <func> <routines> *) 

PROCEDURE routines; 

BEGIN 

[continued) 
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LOOP 

CASE getTokenCIass() OF 
Procedure: proc; 

| Function: func; 

ELSE ungetToken; EXIT; 

END; 

END; 

END routines; 

(* <proc> procedure <id> <formals> ; <types> <vars> <routlnes> <block> 
PROCEDURE proc; 

VAR t:token; 
s:symboI; 
i:CARDINAL; 

BEGIN 

getTokenErrorCheck(t, Identifier, 'procedure name expected*); 
s :*= enterSymbol (t.string, Proc, tUnknown); 
beginRoutine(s); 
forma Is(s); 

tokenErrorCheck(SemicoI on, 'semicolon expected*); 

types(s); 

locaIs(s); 

routines; 

writeRoutineLabeI(s); 
genLocaIs(s); 
genBlock(block(s)); 
writeReturn(sizeFormals(s)); 
wr iteStrings; 

tokenErrorCheck(Semicolon, 'semicolon expected*); 
endRoutlne(s); 

END proc; 

(* <func> ::=• function <id> <formaIs>:<id>; <vars> <routines> <block>; *) 
PROCEDURE func; 

VAR fname, ftype:token; 
s, typeSymboI:symboI; 
i:CARDINAL; 

BEGIN 

getTokenErrorCheck(fname, Identifier, ’function name expected'); 
s := enterSymboI(fname.string, Func, tUnknown); 
beginRoutine(s); 
forma Is(s); 

tokenErrorCheck(Colon, ’colon expected'); 
typeSymboI :■ typeName(); 

IF SymboI.cI ass(typeSymboI) <> ScalarType THEN 

compError("functions can only return scalar types"); 

END; 

tokenErrorCheck(SemicoIon, 'semicolon expected'); 

SymboI.setType(s, typeSymbol); 

types(s); 

locals(s); 

rout 1nes; 

writeRoutineLabel(s); 

genLocaIs(s); 

genBIock(block(s)); 

(* Here we should generate an error message in the code: value not 
returned from function. But since we have no string manipulation, 
we can’t. Instead we'll return either 0 (for an Integer function) or 
false (which is also 0) for a boolean function. *) 
wr itelnt(0); 

writeFReturn(sizeFormaIs(s)); 
wr i teStrings; 

tokenErrorCheck(SemicoIon, 'semicolon expected'); 
endRoutine(s); 

END func; 

(* <formals> ::= <empty> | ( <formlist> ) *) 

PROCEDURE forma Is(routine:symboI); 

VAR formList:symboIList; 

offset:INTEGER; 

BEGIN 

IF getTokenCIass() <> Lparen THEN 
ungetToken; 

ELSE 

form Iist(routine); 

tokenErrorCheck(Rparen, 'right paren expected'); 
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(* Set the offsets of the formals *) 
formList := SymboI.forma Is(routine); 
offset := In111 a I FormalOffset; 

WHILE NOT sI Empty(formL1st) DO 

Symbol.setOffset(sISymboI(formList), offset); 

IF openArrayFormaI(sISymbol(formList)) THEN 

INC(offset, 3); (* 2 extra: one for each bound *) 

ELSE 

INC(offset); 

END; 

formList := sI Next(formList); 

END; 

END; 

END formals; 

PROCEDURE openArrayFormaI(s rsymboI):BOOLEAN; 

BEGIN 

RETURN (Symbol.cI ass(SymboI.type(s)) * ArrayType) AND 
Symbol.open(Symbol.type(s)); 

END openArrayFormaI; 

(* <formlist> ::= <formdecl> | <formdecl> ; <formlist> *) 
PROCEDURE formlist(routine:symboI); 

BEGIN 

formdecI(routine); 

IF getTokenCI ass() = Semicolon THEN 
formlist(routine); 

ELSE 

ungetToken; 

END; 

END formlist; 

(* <formdecl> ::= <idIist> : <mode> <typeld> *) 

PROCEDURE formdecI(routine:symboI); 

VAR tl, tokenp:tokenList; 
t:token; 

typeSymbol;symboI; 
mrmodeType; 

BEGIN 

tl idlist(); 

tokenErrorCheckfCoIon, "colon expected") ; 
m formaIMode(); 
getToken(t); 

IF t.class ** Identifier THEN 
ungetToken; 

typeSymbol :« typeName(); 

ELSIF t.class * Array THEN 

tokenErrorCheck(Of, "OF expected"); 

typeSymbol :« newArrayType(typeName(), 0, 0, TRUE, 

currentLexLevel()); 

(* bounds are irrelevant; TRUE indicates open array *) 

ELSE 

compError("type name or open array parameter expected"); 
ungetToken; 

typeSymbol ;■ tUnknown; 

END; 

(* create and enter the symbols *) 
tokenp := tI; 

WHILE NOT tlEmpty(tokenp) DO 
tIToken(tokenp, t); 

enterFormaI(t.string, m, typeSymbol, routine); 
tokenp :* 11 Next(tokenp); 

END; 

freeTokenList(tI); 

END formdecI; 

(* <mode> <empty> | IN | OUT | IN OUT. 

Note: OUT IN is not acceptable. *) 

PROCEDURE formaIMode():modeType; 

VAR t:token; 

BEGIN 

getToken(t); 

IF t.class = In THEN 

IF getTokenCI ass() « Out THEN 
RETURN mlnOut; 

ELSE 
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ungetToken; 
RETURN min; 

END; 

ELSIF t.class = Out THEN 
RETURN mOut; 

ELSE 

ungetToken; 

RETURN min; 

END; 

END formalMode; 


PROCEDURE I oca Is(rout Ine:symboI); 

(* Syntactically, locals look just like globals; but 
into the locals list of the routine and give them 
pointer. Note that since the array handling stuff 
address to be the lowest in the array, we have to 
t arrays 80 tha * the starting address is lowest. 
VAR locListisymbolList; 
offset;INTEGER; 
size:CARDINAL; 

BEGIN 


we have to put them 
offsets from the frame 
expects the starting 
assign the offset 
*) 


END 


vars(routine); 

locList Symbol.locals(routine); 
offset :« initialLocalOffset; 

(* set the offsets of the locals *) 

WHILE NOT slEmpty(locList) DO 

size :« Symbol.size(Symbol.type(sISymboI(locList))); 

locList :« sINext(locList); 

END; J 

locaIs; 


PROCEDURE typeName():symboI; 

VAR t:token; 

s:symboI; 

BEGIN 

getTokenErrorCheck(t, Identifier, "type name expected"); 
s :« findSymbol(t.string); 

IF NOT isTypefs) THEN 

compError(* type name expected*); 
s :* tUnknown; 

END; 

RETURN s; 

END typeName; 


PROCEDURE sizeFormaIs(routine:symboI):CARDINAL• 

( * thI U nuLlrV? U ? b6r ? f T? 8 0ccupied *>y forma I s. Before this was just 

(For its boCJdl o'"*) 8 ’ tUt " 0W 6aCh 0pe " ° rray P<lr<,m ° ddS 2 t0 the count - 

VAR formIist:symboIList; 


sum:CARDINAL; 
t:symboI; 
BEGIN 


formlist :« SymboI.forma Is(routine); 
sum :« 0; J 

WHILE NOT sIEmpty(formlist) DO 

t := Symbol.type(sISymboI(formlist)); 

IF tS/ 01 - c, a8s(t) = ArrayType) AND Symbo I .open(t) THEN 
XNU(sum, 3)» 

ELSE 


INC(sum); 

END; 

formlist := sI Next(form Iist); 
END; J 

RETURN sum; 

END sizeFormals; 


BEGIN 

END Routines. 


Start SymboI.DEF 
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(* The symbol data structure contains all the information about symbols (like 
variables and routine names). Symbol lists are used for lists of formals 
and locals. 

Changes made for part 3: 

1. The word "symbol" has been removed from all routine names. Instead, 
the module will be imported whole (IMPORT Symbol) and the module 
name will serve to identify the routines (e.g. SymboI.empty). 

Also, SymbolClass —> Class. 

2. symboITokCI ass —> tokClass; setSymboITokCI ass —> setTokenCI ass. 

3. The number of symbol classes has been expanded. 

4. The function tokenCIassToType has been moved here from Token to 
avoid circular references between Token.DEF and Symbol.DEF. 

5. The type mode and the function tokenCIassToMode have been added. 


FROM Token IMPORT stringType, tokenClass; 

EXPORT QUALIFIED symbol, emptySymbol, Class, class, string, type, lexLevel, 
offset, formals, locals, next, prev, tokClass, 

setFormaIs, setLocals, setType, setNext, setPrev, setOffset, setTokenCI ass, 

classEqual, empty, equal, new, free, numFormals, numLocals, 

symboI List, emptySymboIList, si Empty, siSymboI, si Next, addToSymboIList, 

freeSymboIList, modeType, isType, mode, setMode, size, setSize, 

highBound, lowBound, setBounds, open, setOpen, newArrayType, 

anonymous, copyArrayType, setstring; 


TYPE 

symboI; 
symboI List; 

Class = (* the different kinds of symbols *) 

(Proc, Func, ScalarType, ArrayType, Global, Local, Formal, Keyword, 
UndecIared); 

modeType = (min, mOut, mlnOut); 


VAR emptySymboI:symboI; 

emptySymboIList:symboILIs t; 

(*** Symbols ***) 


PROCEDURE cI ass(s:symboI):CI ass; 

(* Return the class of the symbol *) 

PROCEDURE string(s:symboI; VAR str:strIngType); 

PROCEDURE setString(s:symboI; str:ARRAY OF CHAR); 

(* Return or set the name of the symbol, as a string *) 

(* Symbols are declared to be of a certain type (except procedures) *) 

PROCEDURE type(s:symboI):symboI; 

PROCEDURE setType(s, t:symbol); 

PROCEDURE IexLeveI(s:symboI):CARDINAL; 

(* Return the lexical level at which the symbol was declared *) 

(* Each formal and local has an offset from the frame pointer. *) 
PROCEDURE offset(s:symboI):INTEGER; 

PROCEDURE setOffset(s:symboI; o:INTEGER); 

(* Formals also have a mode. *) 

PROCEDURE mode(s:symboI):modeType; 

PROCEDURE setMode(s:symboI; m:modeType); 

(* Type objects have an associate size. *) 

PROCEDURE size(s:symboI):CARDINAL; 

PROCEDURE setsize(s:symboI; c:CARDINAL); 

(* Array types have bounds, and a Boolean for open array paroms. *) 
PROCEDURE IowBound(s:symboI):INTEGER; 

PROCEDURE highBound ( s:symboI):INTEGER; 

PROCEDURE setBounds(s:symboI; low, high:INTEGER); 


[continued) 
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PROCEDURE open(s:symbol):BOOLEAN; 

PROCEDURE setOpen(s:symboI; b:BOOLEAN); 

(* These ore for routines. They get and set the lists of formals and locals. *) 
PROCEDURE forma Is(s:symboI):symboILIst; 

PROCEDURE I oca Is(s:symboI):symboILIst; 

PROCEDURE setFormaIs(s:symboI; sI:symboIL1st); 

PROCEDURE setLocaIs(s:symboI; sI:symboILlst); 

(* Return the number of formals or locals in the routine. *) 

PROCEDURE numFormals(s:symbol ) -.CARDINAL; 

PROCEDURE numLocaIs(e:eymboI):CARDINAL; 

(* These next two are for implementing a doubly linked list. See SymboI Tab Ie.*) 
PROCEDURE next(s:symbol):symboI ; 

PROCEDURE prev(s:symbol):symboI; 

PROCEDURE setNext(s1, s2:symbol); 

PROCEDURE setPrev(s1, s2:symbol); 

(* Keyword symbols have a corresponding token class. *) 

PROCEDURE tokCI ass(s:symboI):tokenClass; 

PROCEDURE setTokenCIass(s:symboI; tc;tokenCIass); 

PROCEDURE classEqual(srsymbol; sc:CI ass):BOOLEAN; 

(* Returns TRUE if the class of s equals sc. *) 

PROCEDURE equal(si, s2:symboI):BOOLEAN; 

(* Returns TRUE If the two symbols are the same. *) 

PROCEDURE empty(s:symboI):BOOLEAN; 

(* Returns TRUE if the symbol is the emptySymbol. *) 

PROCEDURE anonymous(s:symboI):BOOLEAN; 

(* TRUE iff the array type is anonymous, i.e. unnamed. *) 

PROCEDURE new(str:strIngType; sc;CIass; scop:CARDINAL; 

typ:symboI ): symboI; 

(* Creates a new symbol. *) 

PROCEDURE newArrayType(baseType:symboI; lowBound, highBound:INTEGER; 

open:BOOLEAN; IexLevtCARDINAL);symboI; 

(* Creates a new array type object. *) 

PROCEDURE copyArrayType(s:symbol):symbol; 

(* Copies an array type object *) 

PROCEDURE free(s:symbol); 

(* Frees the storage associated with s. *) 

PROCEDURE isType(s:symboI):BOOLEAN; 

(* TRUE if the class of s is ArrayType or ScalarType. *) 

(*** Symbol Lists ***) 

PROCEDURE si Empty(si:symboIList);BOOLEAN; 

(* Returns TRUE if si is the empty symbol list. *) 

PROCEDURE sI Next(sI:symboIList):symboIList; 

(* Gets the rest of the symbol list. *) 

PROCEDURE sISymboI(sI:symboI List):symboI; 

(* Gets the first symbol in the list *) 

PROCEDURE addToSymbolList(s:symbol; si:symboI List):symboI List; 

(* Adds s to si at the front. Return the new symbol list. *) 

PROCEDURE freeSymboIList(sI:symboIList); 

(* Frees the storage associate with si (but NOT the storage of the symbols 
in si! *) 

END Symbol. 


Start Symbol.MOD 
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IMPLEMENTATION MODULE Symbol; 

(* Symbol and symbol list data structures. 

Changes made for part 3: 

1. The symbolRec data structure has been reorganized. 

2. Procedures have been added to access the new fields in a symbol, 
and to create array type objects. 

3. roffset for routines: used only for the hack (in 

SymboI Tab Ie.beginRoutine) that assigns a unique number to non-global 
routines. 

*) 

FROM Token IMPORT stringType, tokenClass; 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM MyTerminaI IMPORT fatal; 

FROM SymboI Table IMPORT tUnknown; 

FROM StringStuff IMPORT stringCopy; 

TYPE 

symbol » POINTER TO symbolRec; 
symboI List = POINTER TO sIRec; 

symbolRec * RECORD 

string: stringType; 

IexLeveI: CARDINAL; 
type: symbol; 
next, prev: symbol; 

CASE class: Class OF 

Proc, Func; formals, locals: symbolList; 

roffset:INTEGER; 

Local: loffset:INTEGER; 

Formal: foffset:INTEGER; mode: modeType; 

Sea IarType: size: CARDINAL; 

ArrayType: asizeCARDINAL; lowBound, highBound:INTEGER; 
open:BOOLEAN; 

| Keyword: tokClass: tokenClass; 

END; 

END; 

sIRec « RECORD 

sym: symbol; 
next: symbolList; 

END; 

Cset * SET OF Class; 

(*** getting fields ***) 

PROCEDURE cI ass(s:symboI):CI ass; 

BEGIN 

RETURN s^.class; 

END class; 

PROCEDURE string(s:symbol; VAR str:stringType); 

BEGIN 

str :» s^.string; 

END string; 

PROCEDURE type(s:symbol):symboI; 

BEGIN 

RETURN s*.type; 

END type; 

PROCEDURE isType(s:symboI):BOOLEAN; 

BEGIN 

RETURN (s*.class IN Cset{ArrayType, ScalarType}) OR (s ■ tUnknown); 

END isType; 

PROCEDURE IexLeveI(s:symboI):CARDINAL; 

BEGIN 

RETURN s A .IexLeveI; 

END I exLeveI; 

PROCEDURE offset(s:symboI):INTEGER; 


{continued) 
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BEGIN 

IF s*.class =* Formal THEN 
RETURN s^.foffset; 

ELSIF s^.class « Local THEN 
RETURN s~.loffset; 

ELSIF s~.class IN CsetjProc. Func} THEN 
RETURN s*.roffset; 

ELSE 

fata I(’SymboI.offset: not a Formal, Local or routine’) 

END; 

END offset; 

PROCEDURE mode(s:symboI)rmodeType; 

BEGIN 

IF s^.class » Formal THEN 
RETURN s^.mode; 

ELSE 

fata I(*SymboI.mode: not a formal*); 

END; 

END mode; 

PROCEDURE size(s:symboI):CARDINAL; 

BEGIN 

IF s*.class * ArrayType THEN 
RETURN s^.asize; 

ELSIF s^.class « ScalarType THEN 
RETURN s^.size; 

ELSE 

fataI(*SymboI.sIze: not a type object*); 

END; 

END size; 

PROCEDURE highBound(s:symboI):INTEGER; 

BEGIN 

IF s^.class » ArrayType THEN 
RETURN s^.highBound; 

ELSE 

fataI(*SymboI.highBound: not an array type*); 

END; 

END hi ghBound; 

PROCEDURE IowBound(s:symboI):INTEGER; 

BEGIN 

IF s*.class = ArrayType THEN 
RETURN s A .IowBound; 

ELSE 

fataI(*SymboI.IowBound; not an array type’); 

END; 

END IowBound; 

PROCEDURE open(s:symboI):BOOLEAN; 

BEGIN 

IF s*.class = ArrayType THEN 
RETURN s^.open; 

ELSE 

fataI(*S>mboI.open; not an array type*); 

END; 

END open; 

PROCEDURE forma Is(s:symboI):symboIList; 

BEGIN 

IF s^.class IN CsetjProc, Func} THEN 
RETURN s^.forma Is; 

ELSE 

fataI(*SymboI.forma Is; not a proc or func*); 

END; 

END formals; 

PROCEDURE I oca Is(s:symboI);symboIList; 

BEGIN 

IF s^.class IN CsetjProc, Func} THEN 
RETURN s*.locals; 

ELSE 

fataI(* I oca Is : not a proc or func*); 

END; 

END locals; 
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PROCEDURE next(s:symboI):symbol; 

BEGIN 

IF s = emptySymbol THEN 

fatal('Symbol.next: empty symbol given'); 

ELSE 

RETURN s*.next; 

END; 

END next; 

PROCEDURE prev(s:symboI):symboI; 

BEGIN 

RETURN s*.prev; 

END prev; 

PROCEDURE tokCI ass(s:symbol):tokenCI ass; 

BEGIN 

IF s*.class = Keyword THEN 
RETURN s*.tokCI ass; 

ELSE 

fataI(*SymboI.tokCI ass: not a keyword'); 

END; 

END tokClass; 

(*** setting fields ***) 

PROCEDURE setString(s:symboI; str:ARRAY OF CHAR); 

VAR i;CARDINAL; 

BEGIN 

str ingCopy(s*.str ing, str ); 

END setstring; 

PROCEDURE setFormaIs(s:symboI; sI:symboIList); 

BEGIN 

IF s*.class IN CsetjProc, Func} THEN 
s*.forma Is sI; 

ELSE 

fatal('setFormals: not a proc or func'); 

END; 

END setFormals; 

PROCEDURE setLocaIs(s:symboI; sI:symboIList); 

BEGIN 

IF s*.class IN CsetjProc, Func} THEN 
s*.locaIs :* si; 

ELSE 

fatal('setLocals: not a proc or func'); 

END; 

END setLocals; 

PROCEDURE setType(s1, trsymbol); 

BEGIN 

si*.type :■ t; 

END setType; 

PROCEDURE setNext(s1, s2:symbol); 

BEGIN 

si*.next :■ s2; 

END setNext; 

PROCEDURE setPrev(s1, s2:symbol); 

BEGIN 

si*.prev :« s2; 

END setPrev; 

PROCEDURE setOffset(s:symboI; o:INTEGER); 

BEGIN 

IF s*.class - Formal THEN 
s*.foffset o; 

ELSIF s*.class - Local THEN 
s*.loffset o; 

ELSIF s*.class IN CsetjProc, Func} THEN 
s*.roffset :■ o; 

ELSE 

fatal('Symbol.setOffset: not a formal, local, or routine’); 

END; 

END setOffset; 

(continued^ 
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PROCEDURE setMode(s:symboI; mimodeType); 

BEGIN 

IF s*.class » Formal THEN 
s^.mode :■ m; 

ELSE 

fataI(’SymboI.setMode: not a Formal'); 

END; 

END setMode; 

PROCEDURE sets Ize(s:symboI; c:CARDINAL); 

BEGIN 

IF s^.class * ScalarType THEN 
s~.size :« c; 

ELSIF s^.class = ArrayType THEN 
s~.asize :® c; 

ELSE 

fatal(’Symbol.setSize: not a type object'); 

END; 

END setSize; 

PROCEDURE setBounds($:symboI; low, high:INTEGER); 
BEGIN 

IF s A .class = ArrayType THEN 
s^.lowBound :« low; 
s^.hlghBound :» high; 

ELSE 

fata I(’SymboI.setBounds: not an array type’); 

END; 

END setBounds; 


PROCEDURE setOpen(s:symboI; b:BOOLEAN); 

BEGIN 

IF s^.class » ArrayType THEN 
s^.open :« b; 

ELSE 

fata I('SymboI.setOpen; not an array type’); 

END; 

END setOpen; 

PROCEDURE setTokenCIass(s:symboI; tc:tokenCI ass); 
BEGIN 

IF s^.class * Keyword THEN 
s^.tokClass := tc; 

ELSE 

fataI('setTokenCI ass: not a keyword'); 

END; 

END setTokenCI ass; 

(*** other symbol procedures ***) 

PROCEDURE anonymous(s:symboI):BOOLEAN; 

(* TRUE Iff the array Is anonymous *) 

BEGIN 

RETURN s~.string[0] = 0C; 

END anonymous; 

PROCEDURE c I assEquaI(s:symboI; sc:CIass):BOOLEAN; 
BEGIN 

RETURN (s^.class =* Undeclared) OR (s^.class = sc) 
END cIassEquaI; 

PROCEDURE equal(si, s2:symboI):BOOLEAN; 

BEGIN 

RETURN si = s2; 

END equaI; 

PROCEDURE empty(s:symboI):BOOLEAN; 

BEGIN 

RETURN s = emptySymbol; 

END empty; 

PROCEDURE new(str;strIngType; sc:Class; ll:CARDINAL; 
typ:symboI):symboI; 

VAR s:symboI; 

BEGIN 
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NEW(s); (* should be: NEW(s, sc); *) 

WITH s" DO 

string := str; 

IexLeveI :* II; 
type :« typ; 
next :* emptySymbol; 
prev :* emptySymbol; 
class :* sc; 

CASE class OF 
Proc, Func: 

formals :» emptySymboILIst; 
locals := emptySymboI List; 

Formal: foffset :« 0; mode := min; 

LocaI: I of fset := 0; 

ArrayType: open :* FALSE; 

ScalarType: size := 1; 

ELSE (* do nothing *) 

END; 

END; 

RETURN s; 

END new; 

PROCEDURE newArrayType(baseType:symboI; lowBound, highBound:INTEGER; 

open:BOOLEAN; IexLev:CARDINAL):symboI; 

VAR ato:symboI; 

BEGIN 

ato :« new( ,,M , ArrayType, lexLev, baseType); 
setBounds(ato, lowBound, highBound); 
setOpen(ato, open); 

setsize(ato, size(baseType) * CARDINAL(highBound-IowBound+1)); 

RETURN ato; 

END newArrayType; 

PROCEDURE copyArrayType(s:symboI):symboI; 

BEGIN 

RETURN newArrayType(type(s), lowBound(s), highBound(s), open(s), 

I exLeveI(s)); 

END copyArrayType; 

PROCEDURE free(s:symbol); 

BEGIN 

DISPOSE(s); (* should be: DISPOSER, s*. class); *) 

END free; 

PROCEDURE numFormaIs(s:symboI):CARDINAL; 

VAR formList:symbolList; 

count CARDINAL; 

BEGIN 

count :■ 0; 

formList :» formals(s); 

WHILE NOT sI Empty(formList) DO 
INC(count); 

formList := sINext(formList); 

END; 

RETURN count; 

END numFormaIs; 

PROCEDURE numLocals(s:symbol):CARDINAL; 

VAR locList:symboIList; 

count CARDINAL; 

BEGIN 

count :■ 0; 

locList :* locals(s); 

WHILE NOT sI Empty(IocL1st) DO 
INC(count); 

locList :■ sINext(locList); 

END; 

RETURN count; 

END numLocals; 

(*** symbolList ***) 

PROCEDURE sIEmpty(sI:symboILis t):BOOLEAN; 

BEGIN 

RETURN sl * emptySymboI List; 

END slEmpty; 

(continued) 
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PROCEDURE 6 I Next(si:symboIList):symboILlst; 

BEGIN 

RETURN s I next; 

END si Next; 

PROCEDURE sISymboI(sI:symbo Hist):symboI; 

BEGIN 

RETURN sl^.sym; 

END sISymboI; 

PROCEDURE addToSymbolList(s:symbol; si:symboIList):symboIList; 
VAR news I: symboI List; 

BEGIN 

NEW(newsl); 
newsl^.sym :* s; 
news Inext :* sI; 

RETURN news I; 

END addToSymboILIs t; 

PROCEDURE freeSymbolList(sI:symboIList); 

BEGIN 

IF NOT si Empty(si) THEN 

f reeSymboIList(sI Next(sI)); 

DISPOSER I ); 

END; 

END freeSymboIList; 


BEGIN 

emptySymbol :* NIL; 
emptySymbolList : = NIL; 
END Symbol. 


Start SymbolTable.DEF 


DEFINITION MODULE SymboI Table; 

(* The symbol table associates symbol records with names of symbols. *) 

FROM Symbol IMPORT symbol, Class, modeType; 

FROM Token IMPORT stringType, tokenClass; 

EXPORT QUALIFIED enterSymbol, enterLocal, enterFormal, findSymbol, findKeyword, 
enterKeyword, beginRoutine, endRoutine, currentLexLeveI, 

enterArrayType, tUnknown, tBoolean, tChar. tlnteger. tString, 
lowFunc, highFunc; 

(* These are the type objects of the built-in types. *) 

VAR tUnknown, tBoolean, tChar, tlnteger, tString:symbol; 

lowFunc, highFuncisymbol; (* symbols for pseudo-functions LOW k HIGH *) 

PROCEDURE cur rentLexLeve I ( ) -.CARDINAL; 

(* Returns the current lexical level *) 


(* Enter global, local, formal, keyword symbols into the table. 

enterSymbol is the general routine and returns the entered symbol. If the 
symbol Is already present, or if it is a built-in, an error is signalled. 
EnterLocal and enterFormal are used for local variables and formal 
parameters only; they take care of inserting the symbol into the list of 
locals or formals, respectively, which is associated with the routine. 
enterArrayType is for giving a name to array type objects. ★) 

PROCEDURE enterSymboI(VAR s:stringType; symcrClass; type:symboI):symboI; 

PROCEDURE enterLocaI(VAR s:stringType; type, routine:symboI); 

PROCEDURE enterFormaI(VAR s:stringType; modermodeType; type, routine:symboI) 

PROCEDURE enterKeyword(s:stringType; tc:tokenCI ass); 

PROCEDURE enterArrayType(VAR s:stringType; typeObject:symboI); 

PROCEDURE findSymbol(VAR s:stringType)rsymbol; 

(* Look up the symbol in the table and return it. Return the empty symbo! 
if not found. *) 

PROCEDURE findKeyword(VAR s:stringType; VAR tc:tokenCIass):BOOLEAN; 

(* Look up the keyword in the table and put its corresponding token class 
in tc. Return FALSE if the symbol wasn't found. *) 
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PROCEDURE beginRoutine(rname:symbol); 

(* To be called just after the routine name has been entered. Increments 
lexical level. Also assigns a unique number to the routine if it isn't 
globaI. *) 

PROCEDURE endRoutine(rname:symboI); 

(* Clean up the symbol table after a routine has been compiled. This includes 
deleting the locals and formals from the table. *) 

END SymboI Table. 


Start SymboI Tab Ie.MOD 


IMPLEMENTATION MODULE Symbol Table; 

(* The symbol table for the SIMPL compiler. It is a hash table; each entry 
is a symboI,possibly linked through the NEXT field to other symbols. The 
list of symbols is doubly linked, to make it easy to delete from the middle. 
We still have to rehash to delete from the beginning, though. This could 
be gotten around by hanging a dummy record off of every hashtable entry. 

*) 


FROM Symbol IMPORT symbol, emptySymbol, symboI List, addToSymboIList, modeType, 
sISymbol, sINext, slEmpty, Class, freeSymboIList, emptySymboIList; 

IMPORT Symbol; 

FROM Token IMPORT stringType, tokenClass; 

FROM LexAn IMPORT compError; 

FROM MyTerminaI IMPORT fatal; 

FROM StringStuff IMPORT stringEqual; 

CONST symTabSize = 20; 

(* This is NOT an upper limit on the number of symbols, 

since we have linked lists coming off of the hashtable entries. Still, 
the compiler may run faster (because the lists it searches are shorter) 

If this number is increased. *) 

VAR symbolTable: ARRAY[0..symTabSize-1] OF symbol; 
lexica I Level; CARDINAL; 

PROCEDURE cur rentLexLeveI():CARDINAL; 

BEGIN 

RETURN lexica I Level; 

END currentLexLevel; 

PROCEDURE enterLocaI(VAR s:stringType; type, routine:symboI); 

VAR sym:symboI; 

BEGIN 

sym := enterSymboI(s, Local, type); 

IF NOT Symbol.empty(sym) THEN 
Symbol.setLocaIs(routine, 

Symbol.addToSymboI List(sym, Symbol.I oca Is(routine))); 

END; 

END enterLocaI ; 

PROCEDURE enterFormaI(VAR s:stringType; mode;modeType; type, routine:symboI); 

VAR sym:symbol; 

BEGIN 

sym := enterSymboI(s, Formal, type); 

IF NOT SymboI.empty(sym) THEN 
SymboI.setMode(sym, mode); 

Symbol.setFormaIs(routine, 

Symbol.addToSymboI List(sym, Symbol.forma Is(routine))); 

END; 

END enterFormaI; 

PROCEDURE enterKeyword(s:stringType; tc:tokenClass); 

VAR sym:symboI; 

BEGIN 

sym :« enterSymboI(s, Keyword, tUnknown); 

SymboI.setTokenCIass(sym, tc); 

END enterKeyword; 

(continued) 
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PROCEDURE enterArrayType(VAR s:stringType; typeObject:symboI); 

(* Enter the array type object into the symbol table with the given name. 

Does NOT create a new symbol. *) 

BEGIN 

IF NOT isBuiitln(s) THEN 

Symbol. setString(typeObject, s); 

EL SE type0b ^ ect (* dumm y *) Insert(typeObject, hash(s)); 

compError("cannot redefine a built-in name"); 

END; 

END enterArrayType; 

(*** symbol insertion ***) 

PROCEDURE enterSymbol(VAR s:stringType; symc:SymboI.CI ass; type;symboI):symboI 
(* This does the real work of entering a symbol. It signals an error 
If a symbol is redefined, or a built-in. *) 

BEGIN 

IF NOT isBuiI tin(s) THEN 

RETURN enterSym(s, symc, type); 

ELSE 

compError("can*t redefine a built-in symbol"); 

RETURN emptySymbol; 

END; 

END enterSymboI; 

PROCEDURE enterSym(VAR s:stringType; symc;SymboI.CI ass; type:symboI):symboI; 

(* enters a symbol without doing built-in checking *) 

VAR sym:symbol; 

h:CARDINAL; 

BEGIN 

sym :* lookup(s, FALSE, h); 

IF SymboI.empty(sym) THEN 

RETURN insert(SymboI.new(s, symc, I ex IcaILeveI, type), h); 

ELSE 

compError(*redefined symbol*); 

RETURN sym; 

END; 

END enterSym; 


(*** symbol lookup ***) 

PROCEDURE findSymboI(VAR s:stringType):symboI; 

VAR sym: symbol; 

h: CARDINAL; 

BEGIN 

sym :« lookup(s, TRUE, h); 

IF SymboI.empty(sym) THEN 

compError(*undefined symbol*); 

RETURN insert(Symbol.new(s, Undeclared, 0, tUnknown), h); 

ELSE 

RETURN sym; 

END; 

END findSymboI; 

PROCEDURE findKeyword(VAR s:stringType; VAR tcitokenClass);BOOLEAN; 

(* This is used by the lexical analyzer to return the keyword’s token class. 
Returns true if the keyword is found; tc will then contain the token 
class of the keyword. *) 

VAR sym:symbol; 

h:CARDINAL; 

BEGIN 

sym := lookup(s, TRUE, h); 

IF Symbol.empty(sym) OR (SymboI.cIass(sym) <> Keyword) THEN 
RETURN FALSE; 

ELSE 

tc := SymboI.tokCIass(sym); 

RETURN TRUE; 

END; 

END flndKeyword; 

PROCEDURE lookup(VAR s:strIngType; anything:BOOLEAN; VAR h:CARDINAL):symboI; 
(* Looks up the string in the symbol table. Returns the empty symbol if 
the string isn’t found; if it is, returns the symbol and, in h, the hash 
value, anything TRUE means: "match anything". 
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This is what findSymbol uses. We match lexical level on insertion, to 
check for redefined symbols. 

*) 

VAR sym: symbol; 

syms: stringType; 

BEGIN 

h :* hash(s); 

sym := symboITabIe[h]; 

WHILE NOT Symbol.empty(sym) DO 
SymboI.string(sym, syms); 

IF stringEquaI(syms, s) AND 

(anything OR (I exicaILeveI = SymboI.IexLeveI(sym))) THEN 
RETURN sym; 

END; 

sym :*= Symbo I . next (sym); 

END; 

RETURN SymboI.emptySymboI; 

END lookup; 


PROCEDURE insert(s:symboI; h:CARDINAL):symboI; 

(* Link the symbol into the h’th symbol table entry. The symbol is put at 
the front of the list. *) 

BEGIN 

Symbol.setNext(s, symboI Tab Ie[h]); 

SymboI.setPrev(s, SymboI.emptySymboI); 
symboITabIe[h] :« s; 

RETURN s; 

END insert; 

MODULE begRout; (* This needs to be a module because a variable needs 
to be remembered across invocations. *) 

IMPORT symboI, lexicalLeveI; 

IMPORT Symbol; 

EXPORT beginRoutine; 

VAR num:INTEGER; 

PROCEDURE beginRoutine(rname:symboI); 

BEGIN 

IF Symbol.IexLeveI(rname) <> 0 THEN (* assign a unique number to *) 
Symbol.setOffset(rname, num); (* non-global procedures *) 
INC(num); 

END; 

INC(lexicalLevel); 

END beginRoutine; 

BEGIN 

num :« 0; 

END begRout; 

PROCEDURE endRoutine(rname:symboI); 

(* This is the stuff we do at the end of compiling a procedure or function. 

The free’s are just to reclaim storage. The remove’s remove the symbols 
from the symbol table, which is important if some local symbol is 
shadowing a global symbol. We remove both locals and formals, but we don’t 
free the formals because we need them for type checking. 

We also remove the routines declared at this lexical level, and free their 
formals. We find these routines by searching the entire symbol table—it 
would probably be better to keep a list of them. 

We also remove the types declared at this level, again by exhaustive 
search. 

*) 

BEGIN 

removeSymbolList(Symbol.locals(rname)); 
freeSymboIs(SymboI.locaIs(rname)); 

Symbol.freeSymbolList(Symbol.I oca Is(rname)); 

Symbol.setLocaIs(rname, Symbol.emptySymboIList); 
removeSymboIList(SymboI.forma Is(rname)); 
removeRout1nesAtThIsLeveI; 

DEC(lexicalLeveI); 

END endRoutine; 


PROCEDURE removeSymboIList(symboIp:symboIList); 

( continued) 
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BEGIN 

WHILE NOT Symbol.slEmpty(symbolp) DO 

removeSymboI(Symbol.sISymboI(symboIp)); 
symbolp :■ SymboI.sI Next(symboIp); 

END; 

END removeSymboILIst; 

PROCEDURE removeRoutInesAtThIsLeveI; 

(* Remove oil routines defined at this lexical level. Free their formals. 

All the symbols at this lexical level will be at the beginning of their 
respective buckets in the symbol table, and they all will be routines. 

Now removes types too. *) 

VAR i:CARDINAL; 

s, next:symboI; 

BEGIN 

FOR i :■ 0 TO symTabSize-1 DO 
s :« symboITabIe[i]; 

WHILE (NOT Symbol.empty(s)) AND (SymboI.IexLeveI(s) * I exicaILeveI) DO 
IF NOT SymboI.IsType(s) THEN (* it’s a routine *) 
freeSymboIs(SymboI.forma Is(s)); 

Symbol.freeSymboIList(SymboI.formals(s)); 

END; 

(* remove this symbol from the table *) 
next :« Symbol.next(s); 
symboI Tab Ie[i] :« next; 

IF NOT SymboI.empty(next) THEN 

SymboI.setPrev(next, SymboI.emptySymboI); 

END; 

SymboI.free(s); 
s :» next; 

END; 

END; 

END removeRoutInesAtThIsLeveI; 

PROCEDURE removeSymboI(s:symboI); 

(* Splice the symbol out of the symbol table. If the symbol is at the 
beginning of the list, we have to rehash to find the right entry. 

Otherwise, just remove it from the list. *) 

VAR bucket:CARDINAL; 

syms: stringType; 

BEGIN 

IF SymboI.empty(SymboI.prev(s)) THEN 
Symbol .str ir,g(s, syms); 
bucket :* hash(syms); 

IF NOT Symbol.equal(symboI Tab Ie[bucket], s) THEN 
fata I(*removeSymboI: error*); 

ELSE 

symboI Tab Ie[bucket ] :* Symbol.next(s); 

IF NOT Symbol.empty(SymboI.next(s)) THEN 

Symbol.setPrev(SymboI.next(s), Symbol.emptySymboI); 

END; 

END; 

ELSE 

Symbol.setNext(SymboI.prev(s), Symbol.next(s)); 

IF NOT Symbol.empty(SymboI.next(s)) THEN 

Symbol.setPrev(SymboI.next(s), Symbol.prev(s)); 

END; 

END; 

END removeSymboI; 

PROCEDURE freeSymboIs(symboIp:SymboI.symboIList); 

VAR nextSymboI:SymboI.symboIList; 

BEGIN 

WHILE NOT SymboI.sIEmpty(symboIp) DO 

nextSymbol := Symbol.sINextfsymboIp); 

SymboI.free(SymboI.sISymboI(symboIp)); 
symbolp := nextSymbol; 

END; 

END freeSymboIs; 


(*** low-level stuff ***) 

PROCEDURE hash(VAR s:stringType)rCARDINAL; 

(* A simple hash function: just add up the ASCII values of the characters. *) 
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VAR i. sum:CARDINAL; 

BEGIN 

i 0; 
sum := 0; 

WHILE s[i] <> 0C DO 

sum :«= sum + ORD(s[i]); 

INC(i); 

END; 

RETURN sum MOD symTabSize; 

END hash; 

MODULE Bui I tins; 

IMPORT stringType, stringEqual, enterSym, fatal, symbol, emptySymbol; 

IMPORT Symbol; 

EXPORT isBuiltln, enterBuiItIn, enterBuiItInType; 

CONST maxBuI I tins = 10; 

VAR builtlns: ARRAY[1..maxBuiI tins] OF stringType; 
nBuiI tins: [0..maxBuiI tins]; 

PROCEDURE isBuiltIn(VAR s:stringType):BOOLEAN; 

VAR i-.CARDINAL; 

BEGIN 

FOR i :« 1 TO nBuiI tins DO 

IF stringEquaI(s, builtlns[i]) THEN 
RETURN TRUE; 

END; 

END; 

RETURN FALSE; 

END isBuiItln; 

PROCEDURE enterBuiI tin(s:stringType; symc:Symbol.CI ass):symboI; 

BEGIN 

IF nBuiltlns ■ maxBuiltlns THEN 
fatal('too many built-ins’); 

ELSE 

INC(nBuI I tins); 

bu1 11Ins[nBuiI tins] :» s; 

RETURN enterSym(s, symc, emptySymbol); 

END; 

END enterBuIItln; 

PROCEDURE ontorBui 11InType(s:stringType):symboI; 

(* Assumes size scalar types *) 

VAR sym:symbol; 

BEGIN 

sym := enterBuI Itln(s, SymboI.SeaIarType); 

SymboI.setsize(sym, 1); 

RETURN sym; 

END enterBuiItlnType; 

BEGIN (* module Builtlns *) 
nBuiI tins :■ 0; 

END Bui I tins; 

PROCEDURE InitSymbolTable; 

VAR I:CARDINAL; 

BEGIN 

FOR i :■ 0 TO symTabSize-1 DO 

symbolTable[i] := emptySymbol; 

END; 

END InitSymbolTable; 

PROCEDURE enterBuiI tins; 

VAR oneArgrsymbolList; 

BEGIN 

tlnteger :■ enterBuI ItInType("INTEGER"); 
tChar :* enterBuiItInType("CHAR"); 
tBoolean :* enterBuiItInType("BOOLEAN"); 

(* tString isn’t really a built-in type, nor Is STRING a reserved word. 

So Just create a symbol for tString. Do be careful about 
the symbol class and the basetype: some might use that info in 
type-checking (e.g. writeCheck). Strings are arrays of CHAR. *) 
tString :» SymboI.new("_tString", ArrayType, I exicaILeveI, tChar); 

[continued) 
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(* tUnknown Is a total dummy, but It shouldn't be equal to the empty 
symbol nonetheless. *) 

tUnknown Symbol.new( H _tUnknown", ScalarType, lexicalLevel, emptySymboI); 

(* LOW and HIGH built-in functions can be treated as ordinary 

functions by everything except the code generator. Give them a dummy 
formal for type-checking purposes. The formal will correctly default to 
mode IN. *) 

oneArg :* addToSymboILIst(SymboI.new("^dummy", Formal, lexicalLevel, 

tUnknown), emptySymboIList); 

lowFunc :* enterBuiItIn("LOW", Func); 

Symbol.setFormals(lowFunc, oneArg); 

SymboI.setType(lowFunc, tInteger); 

highFunc :■ enterBuiItIn("HIGH", Func); 

Symbol.setFormaIs(highFunc, oneAra); 

Symbol.setType(highFunc, tlnteger); 

END enterBuiI tins; 


BEGIN 

lexicalLevel := 0; 
inltSymbolTable; 
enterBuI I tins; 

END SymboI Table. 


Start Token.DEF 


DEFINITION MODULE Token; 

(* Tokens are what the lexical analyzer returns to the parser. Keywords are 
distinct tokens, as are the special characters like parens, colon, etc. 
TokenLists are lists of tokens; they are used in the "varlist" 
procedure of the parser. 

Changes made for part 3; 

1. New tokens have been added for the new constructs. 

2. The function tokenCIassToType has been moved to Symbol to avoid 
circular references between Token.DEF and Symbol.DEF. 

3. The function isType has been renamed isBuiItinType. 

*) 

EXPORT QUALIFIED token, tokenClass, stringType, stringlen, isRelation, 
tokenList, emptyTokenList, tIToken, tINext, addToTokenList, 
tIEmpty, freeTokenList; 

CONST stringlen = 80; 

TYPE 

tokenClass = (And, Array, Assignment, Begin, Character, 

Colon, Comma, Divide, Do, DotDot, Else, Elsif, End, EndOflnput, 
Equal, False, Function, Greater, GreaterEquaI, Identifier, If, 

In, Int, Lbracket, Less, LessEqual, Lparen, Minus, Not, 

NotEquaI, Of, Or, Out, Period, Plus, Procedure, 

Program, Rbracket, Read, Return, Rparen, Semicolon, String, Then, 
Times, True, Type, UMinus, Var, While, Write); 


stringType - ARRAY[0..stringIen] OF CHAR; 

token - RECORD 

CASE cI ass:tokenCIass OF 

Identifier, String: string: stringType; 
Int: integer: INTEGER; 

Character: ch: CHAR; 

END; 

END; 

tokenList; 


VAR emptyTokenList: tokenList; 

PROCEDURE isReI ation(tc:tokenClass):BOOLEAN; 

(* Returns TRUE if tc is a relational operator (Equal, Greater, etc.) *) 
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PROCEDURE tIToken(tI:tokenList; VAR t:token); 

(* Gets the first token in the token list. *) 

PROCEDURE 11 Next(tI:tokenList):tokenList; 

(* Gets the rest of the token list. *) 

PROCEDURE addToTokenList(VAR t:token; tI:tokenList):tokenList; 
(* Add a token to the beginning of the token list. *) 

PROCEDURE freeTokenList(tI:tokenList); 

(* Free the storage used by the token list. *) 

PROCEDURE 11 Empty(tI:tokenList);BOOLEAN; 

(* Return TRUE if the token list is empty. *) 

END Token. 


Start Token.MOD 


IMPLEMENTATION MODULE Token; 

(* Tokens and token lists for the SIMPL compiler. *) 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM Terminal IMPORT WriteString; 

TYPE tokenList = POINTER TO tokenListRec; (* token lists are linked lists *) 

tokenLIstRec = RECORD 

tok: token; 
next: tokenList; 

END; 

PROCEDURE isReI ation(tc:tokenCI ass):BOOLEAN; 

BEGIN 

RETURN (tc = Equal) OR (tc » NotEqual) OR (tc = Greater) OR 
(tc = GreaterEquaI) OR (tc ■ Less) OR (tc = LessEqual); 

END isRelation; 

PROCEDURE tIToken(tI:tokenList; VAR t:token); 

BEGIN 

IF tlEmpty(tl) THEN 

WriteString("tIToken: empty tokenList"); 

ELSE 

t :« tr.tok; 

END; 

END tIToken; 

PROCEDURE 11 Next(11:tokenLis t):tokenList; 

BEGIN 

RETURN tr.next; 

END 11 Next; 

PROCEDURE addToTokenList(VAR t:token; tI:tokenList):tokenList; 

(* Create a token list record for the new token and splice it on to the 
front of the token list. Return ( a pointer to) the new record. *) 

VAR newt I: tokenList; 

BEGIN 

NEW(newtl); 
newt I*.tok :* t; 
newt Inext :« 11; 

RETURN newt I; 

END addToTokenList; 

PROCEDURE freeTokenList(tI:tokenList); 

BEGIN 

IF NOT tlEmpty(tl) THEN 

freeTokenList(tI Next(tI)); 

DISPOSER I); 

END; 

END freeTokenL1st; 

PROCEDURE tIEmpty(tl:tokenList):B00LEAN; 

BEGIN 

(continued) 
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RETURN tl ■ emptyTokenList; 
END tIEmpty; 


BEGIN 

emptyTokenList NIL; 
END Token. 


Start TypeChecker.DEF 


DEFINITION MODULE TypeChecker; 

(* Handles the actual type-checking of SIMPL expressions and statements. *) 

FROM Token IMPORT tokenClass; 

FROM Node IMPORT node; 

FROM Symbol IMPORT symbol, modeType; 

EXPORT QUALIFIED typeCompatibIe, opAppropriate, callCheck, readCheck, 
writeCheck, boolCheck, assignCheck, binopCheck, unopCheck, 
returnCheck. assignable, hasMode, typeldentleal, 

IndexCheck, baseType; 

PROCEDURE typeCompatible(t1, t2:symboI):BOOLEAN; 

(* Returns TRUE If tl and t2 are compatible types. In order to avoid 
cascades of error messages, if one or both of the types is tUnknown, 
it still returns TRUE. *) 

PROCEDURE typeldentleal(tl, t2:symboI):BOOLEAN; 

(* Returns TRUE iff tl and t2 are the SAME type. Again, tUnknown is allowed 
to be the same as anything. *) 

PROCEDURE opApproprIate(op:tokenClass; arg:node):BOOLEAN; 

(* Returns TRUE If the type of the argument can be handled by the operator *) 
PROCEDURE calICheck(routine:symbol; argsinode); 

(* Checks the procedure or function call for right number and types of args. * 
PROCEDURE readCheck(actuaIs:node); 

(* Checks the call to the READ built-in procedure. *) 

PROCEDURE wrIteCheck(actuaIsinode); 

(* Checks the call to the WRITE built-in procedure. •) 

PROCEDURE booICheck(ninode); 

PROCEDURE ass IgnCheck(var, exprinode); 

PROCEDURE returnCheck(routIneisymboI; exprinode)iBOOLEAN; 

PROCEDURE binopCheck(opitokenClass; leftarg, rightarg:node)iBOOLEAN; 

PROCEDURE unopCheck(opitokenCI ass; arginode)iBOOLEAN; 

PROCEDURE assignabIe(ninode)iBOOLEAN; 

(* True if s can be assigned to. *) 

PROCEDURE hasMode(nmode; mimodeType)iBOOLEAN; 

(* A node has a particular mode iffi 

1. The node is an index, the array being indexed is a formal and 
the formal has mode m; OR 

2. The node is a symbol, the symbol is a formal and it has mode m. 

*) 

PROCEDURE indexCheck(indexinode); 

(* Checks for compatibility with INTEGER, not of mode OUT *) 

PROCEDURE baseType(typeObjectisymboI)isymboI; 

(* Follows the type field of a symbol until It hits an array type or 
a built-in scalar type. *) 

END TypeChecker. 


194 BYTE LISTINGS SUPPLEMENT 









February 


Start TypeChecker.MOD 


IMPLEMENTATION MODULE TypeChecker; 

(* Handles type-checking of SIMPL expressions. *) 

FROM Node IMPORT node, nodeType, nodeFirst, nodeRest, nodeEmpty, nodeClass, 
NodeClass, nodeSymbol, nodeString, nodeArray, nodeindex; 

FROM Token IMPORT tokenClass, stringType; 

FROM Symbol IMPORT symbol, symbolList, sINext, sISymbol, slEmpty, Class, 
numFormals, emptySymbol, modeType; 

IMPORT Symbol; 

FROM SymboI Tab Ie IMPORT tUnknown, tlnteger, tChar, tBoolean, tString, 
lowFunc, highFunc; 

FROM MyTerminaI IMPORT fatal; 

FROM LexAn IMPORT compError; 

FROM StringStuff IMPORT stringLen; 

TYPE Cset - SET OF Class; 

Nset = SET OF NodeClass; 

PROCEDURE opAppropriate(op:tokenCIass; arg:node):BOOLEAN; 

BEGIN 

CASE op OF 

Plus, Minus, UMinus, Times, Divide: 

RETURN typeCompatible(nodeType(arg), tlnteger); 

| Greater, GreaterEquaI, Less, LessEqual: 

RETURN typeCompatibIe(nodeTypefarg), tlnteger) OR 
typeCompatibIe(nodeType(arg), tChar); 

| And, Or, Not: 

RETURN typeCompatible(nodeType(arg), tBoolean); 

| EquaI, NotEquaI: 

RETURN typeCompatibIe(nodeType(arg), tlnteger) OR 
typeCompatibIefnodeType(arg), tChar) OR 
typeCompatibIe(nodeType(arg), tBooIean); 

ELSE 

fata I("opAppropriate: unknown op type"); 

END; 

END opAppropriate; 

PROCEDURE typeCompat1bIe(t1, t2:symboI):B00LEAN; 

(* Two types are compatible if they have the same base type. *) 

BEGIN 

RETURN typeldentical(baseType(tl), baseType(t2)); 

END typeCompatibIe; 

PROCEDURE typeldent1caI(t1, t2:symboI):BOOLEAN; 

(* Two types are identical iff they are the SAME type object, or if one is 
tUnknown. *) 

BEGIN 

RETURN Symbol.equal(tl, tUnknown) OR 
SymboI.equaI(t2, tUnknown) OR 
SymboI.equaI(t1, t2); 

END typeldentical; 

PROCEDURE baseType(typeObject:symboI):symboI; 

(* Compute the base type of typeObject. *) 

BEGIN 

IF Symbol.empty(typeObject) THEN 
RETURN typeObject; 

END; 

WHILE NOT (SymboI.empty(SymboI.type(typeObiect)) OR 
(Symbol.class(typeObject) = ArrayType)) DO 
typeObject :- SymboI.type(typeObject); 

END; 

RETURN typeObject; 

END baseTypo; 

PROCEDURE calICheck(routine:symbol; args:node); 

(* Tricky because formals are stored backwards in symbol, but forwards 

in the call to the routine. We do nothing if the symbol is not a procedure 
or function; that check is handled in the parser. 

For part 3: special check for lowFunc and highFunc. *) 


( continued) 
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VAR nFormals, nActuaIs:CARDINAL; 

dummy mode; 

BEGIN 

IF Symbol.cI ass(rout Ine) IN CsetfProc, Funcf THEN 
nFormals :« numFormaI sproutIne); 
nActuals :■ lumActuaIs(args); 

IF nActuals < nFormals THEN 

compError(* too few arguments to routine’); 

ELSIF nActuals > nFormals THEN 

compError(* too many arguments to routine'): 

END; 

dummy :■ argsMatch(SymboI.forma Is(routine), args, 

Symbol.equal(routine, lowFunc) OR SymboI.equaI(routine, highFunc)) 

END caIICheck; 

PROCEDURE argsMatch(f list: symbo IL i st; alistinode; I owOrHi gh .-BOOLEAN) inode; 

(* This procedure matches two lists, one of which is backwards. It does 
It by recursing down one list all the way, then iterating down the other 
list while unrecurslng. *) 

BEGIN 

IF sIEmpty(flist) THEN 
RETURN a Iist; 

ELSE 

alist :« argsMatch(slNext(fIist), alist, lowOrHigh); 

IF nodeEmpty(alist) THEN 
RETURN alist; 

ELSE 

argCheck(sISymboI(fIIst), nodeFirst(alist), lowOrHigh); 

RETURN nodeRest(aIist); 

END; 

END; 

END argsMatch; 

PROCEDURE argCheck(formalisymbol; actual inode; IowOrHIgh:BOOLEAN); 

(* An argument matches a formal If: 

The modes are compatible (see modeCompatIbIe, below) AND 

1. The types are IDENTICAL (not compatible) OR 

2. The formal has an open array param as a type, and the 

actual is an array of the identical base type (incl. string) OR 

3. The formal is an array of CHAR and the actual is a string 
constant of size <* the array. 

For LOW and HIGH, all that is required is that the arg be an array. 

*) 

VAR ftype, atype:symboI; 

BEGIN 

IF NOT nodeEmpty(actuaI) THEN 
IF lowOrHigh THEN 

IF NOT Symbol.classEqual(baseType(nodeType(actuaI)), ArrayType) THEN 
compError("LOW and HIGH take only arrays"); 

END; 

ELSIF modeCompatlb Ie(formaI, actual) THEN 
ftype SymboI.type(formaI); 
atype :* nodeType(actuaI); 

IF NOT (typeldenticaI(ftype, atype) OR 
openArray(ftype, atype) OR 
stringConst(ftype, actual)) THEN 
compError('type of formal does not match type of actual*); 

END; 

ELSE 

compError("mode incompatibiIity"); 

END; 

END; 

END argCheck; 

PROCEDURE modeCompatible(formalisymbol; actuaI inode)iBOOLEAN- 
(* TRUE iff: 

1. formal has mode IN and actual does not have mode OUT; OR 

2. formal has mode OUT and actual 

2a. is a variable or index; and 
2b. does not have mode IN; OR 

3. formal has mode IN OUT and actual 

3a. is a variable or index; and 
3b. does not have modes IN or OUT *) 

BEGIN 

IF Symbol.mode(formal) = min THEN 

RETURN NOT hasMode(actuaI, mOut); 
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ELSIF NOT (nodeCI ass(actual) IN Nset{nSymboI, nlndexj) THEN 
RETURN FALSE; 

ELSIF SymboI.mode(formaI) = mOut THEN 
RETURN NOT hasMode(actuaI, min); 

ELSIF SymboI.mode(formaI) = mlnOut THEN 

RETURN (NOT hasMode(actuaI, min)) AND (NOT hasMode(actuaI, mOut)); 

ELSE 

fata I('modeCompatibIe: unknown mode’); 

END; 

END modeCompatibIe; 

PROCEDURE hasMode(n.node; m:modeType):BOOLEAN; 

(* A node has a particular mode iff: 

1. The node is on Index and the array being indexed has mode m; OR 

2. The node is a 8>r.bol, the symbol is a formal and it has mode m. 

*) 

BEGIN 

IF nodeClass(n) *= nlndex THEN 

RETURN hasMode(nodeArray(n), m); 

ELSE 

RETURN (nodeCIass(n) * nSymbol) AND 

(Symbol.cI ass(nodeSymboI(n^) = Formal) AND 
(SymboI.mode(nodeSymboI(n)) = m); 

END; 

END hasMode; 

PROCEDURE openArray(ftype, atype:symboI):BOOLEAN; 

(* TRUE iff ftype is an open array and atype is an array of the identical 
base type. *) 

BEGIN 

RETURN (Symbol.cIass(ftype) = ArrayType) AND 
Symbol.open(ftype) AND 
(Symbol.cI ass(atype) - ArrayType) AND 

typeldent leal(Symbol.type(ftype), Symbol.type(atype)); 

END openArray; 

PROCEDURE stringConst(ftype:symboI; actuaI mode):BOOLEAN; 

(* TRUE iff ftype is an array of char (possibly open} and actual is tString, 
and the string const is shorter than the array. *) 

VAR s:stringType; 

BEGIN 

IF (Symbol,cIass(ftype) * ArrayType) AND 

SymboI.equaI(SymboI.type(ftype), tChar) AND 
SymboI.equaI(nodeType(actuaI), tString) THEN 
nodeString(actual, s); 

RETURN Symbol.open(ftype) OR (stringLen(s) <- SymboI.size(ftype)); 

ELSE 

RETURN FALSE; 

END; 

END stringConst; 

PROCEDURE numActuaIs(actuaIs:node)CARDINAL; 

VAR count:CARDINAL; 

BEGIN 

count :■ 0; 

WHILE NOT nodeEmpty(actuaIs) DO 
INC(count); 

actuals :■ nodeRest(actuaIs); 

END; 

RETURN count; 

END numActuals; 


PROCEDURE readCheck(actuaIsmode); 

VAR argmode; 

BEGIN 

IF nodeEmpty(actuaIs) THEN 

compError('READ requires an argument'); 

ELSE 

REPEAT 

arg :* nodeFirst ( actuaIs); 

IF NOT nodeEmpty(arg) THEN 
IF NOT assignabIe(arg) THEN 

compError('READ must be able to assign to its arguments'); 

END; 


(continued) 


BYTE LISTINGS SUPPLEMENT 197 





February 


IF NOT chorOrInt(nodeType(org)) THEN 

compError('READ can only read Integers or characters'); 

END; 

END; 

actuals :« nodeRest(actuaIs); 

UNTIL nodeEmpty(actuaIs); 

END; 

END readCheck; 

PROCEDURE wrIteCheck(actuaIsinode); 

VAR arginode; 

BEGIN 

IF nodeEmpty(actuaIs) THEN 

compError('WRITE requires an argument'); 

ELSE 

REPEAT 

arg := nodeFIrstfactuaIs); 

IF NOT nodeEmpty(arg) THEN 

IF NOT charOrlnt(nodeType(arg)) THEN 

compError('WRITE can only write integers or characters’ 

END; 

END; 

actuals nodeRest(actuaIs); 

UNTIL nodeEmpty(actuaIs); 

END; 

END wrIteCheck; 

PROCEDURE binopCheck(op:tokenCIass; Ieftarg, rightarg;node):BOOLEAN; 
BEGIN 

IF NOT opAppropriate(op, leftarg) THEN 

compError('inapproprlate arg type: left arg*); 

RETURN FALSE; 

END; 

IF NOT opAppropriate(op, rightarg) THEN 

compError('inapproprlate arg type: right arg’); 

RETURN FALSE; 

END; 

(* The two operands must be THE SAME, not just compatible. *) 

IF NOT typeldentlea I(nodeType(Ieftarg), nodeType(rightarg)) THEN 
compError(’argument types not Identical'); 

RETURN FALSE; 

ELSE 

RETURN TRUE; 

END; 

END binopCheck; 

PROCEDURE unopCheck(op:tokenCI ass; arg:node):BOOLEAN; 

BEGIN 

IF NOT opAppropriate(op, arg) THEN 

compError(*inappropriate arg type'); 

RETURN FALSE; 

ELSE 

RETURN TRUE; 

END; 

END unopCheck; 

PROCEDURE assignCheck(var, exprinode); 

(* For assignment, the types must be identical, unless one is an open 
array, in which case only the base types need be identical. If the 
expr is a string constant, the var need only be an array of char. *) 
VAR t1,t2:symbol; 

BEGIN 

tl :« nodeType(var); 
t2 :* nodeType(expr); 

IF NOT (openArrayft1, t2) OR 
openArray(t2, tl) OR 
typeldentIcaI(t1, t2) OR 
stringConst(t1, expr)) THEN 
compError(*types not assignment-compatible*); 

END; 

END assignCheck; 

PROCEDURE booICheck(n:node); 

BEGIN 

IF NOT typeCompatlb Ie(nodeType(n), tBoolean) THEN 
compError('Boo Iean expression expected'); 

END; 
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END boo I Check; 


PROCEDURE returnCheck(rout 1 ne:symbo I; expr-.node) :BOOLEAN; 

BEG IN 

IF (NOT nodeEmpty(expr)) AND (NOT Symbol .classEquol(routine, Func)) THEN 
compError(’only functions con return values’); 

RETURN FALSE; , _ . 

ELSIF nodeEmpty(expr) AND Symbol.classEquol(routine, Func) THEN 
compError(’function must return a value’); 

RETURN FALSE; 

ELSIF (NOT nodeEmpty(expr)) AND _ . Tuckl 

(NOT typeIdenticoI(SymboI.type(routine), nodeType(expr))) THEN 
compError(’return type not identical to function type’); 

RETURN FALSE; 


ELSE 

RETURN TRUE; 

END; 

END returnCheck; 


PROCEDURE assignabIe(n:node):BOOLEAN; 

(* Something can be assigned to if: it is a variable (including array 
indices), and it does not have mode IN. *) 

BEGIN . , T n 

RETURN variable(n) AND (NOT hasMode(n, min)); 

END assignable; 


PROCEDURE indexCheck(index:node); 

BEGIN 

IF NOT nodeEmpty(index) THEN 

IF hasMode(index, mOut) THEN 

compError("can*t use an OUT formal to index an array"); 

ELSIF NOT typeCompatibIe(nodeType(index), tlnteger) THEN 

compError("array index must be compatible with type INTEGER"); 

END; 

END; 

END indexCheck; 

PROCEDURE variabIe(n:node):BOOLEAN; 

(* TRUE iff n is a symbol of class Global, Local, or Formal; or 
if n is an Index. *) 

BEGIN 

RETURN (NOT nodeEmpty(n)) AND 

((nodeClass(n) * nlndex) OR 
((nodeCIass(n) * nSymbol) AND 

(SymboI.cI ass(nodeSymboI(n)) IN Cset{Global, Local, Formal}))); 
END variable; 


PROCEDURE char0rlnt(trsymbol):BOOLEAN; 

(* TRUE iff t Is a type object compatible with 


CHAR or INTEGER *) 


BEGIN 

RETURN typeCompatibIe(t, 
END charOrlnt; 


tChar) OR typeCompatibIe(t, 


tlnteger); 


BEGIN 

END TypeChecker. 
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mscreen.mod 
TEXT 

"Modula-2 System for Z80 CP/M." See mfiIecpy.mod. 


MODULE MSCREEN; 

FROM TERM1 IMPORT (* non-standard terminal module *) 
Write, WriteCard. WrlteString, WriteLn; 

FROM ASCII IMPORT 
be I, sub; 


VAR 

i : CARDINAL; 


BEGIN 

Write (sub); 
Write (beI); 


(* Clear Console Screen *) 


FOR i := 1 TO 100 DO 
WriteCard (i, 3); 
WriteString 

WriteString (•1234567890*); 
END; 


(• The quick brown fox jumped over 
(•1234567890*); WriteLn; 


the lazy dogs back. *); 


Write (be I); 
END MSCREEN. 


msieve.mod 


TEXT 

"Modula-2 System for Z80 CP/M." 


See mfilecpy.mod. 


MODULE MSIEVE; 

FROM TERM1 IMPORT 

WriteString. WriteCard. WriteLn; 

CONST 

Size - 8190; (* size of array *) 

Iterations - 10; (* minimum 1 *) 


VAR 

count, i, iter, k, prime ; CARDINAL; 
flags ; ARRAY [0..Size] OF BOOLEAN; 


BEGIN 

WriteString (*10 Iterations*); 
FOR iter :« 1 TO Iterations DO 
count :* 0; 


WriteLn; 


FOR i 0 TO Size DO 
fIags[i] :« TRUE; 
END; 


FOR i :« 0 TO Size DO 
IF fIags[i] THEN 

prime :* i + i + 3; 
k :« i + prime; 

WHILE k <* Size DO 
fIags[k] := FALSE; 

INC (k, prime); 

END; 

INC (count); 

END; 

END; (* FOR *) 

END; (* FOR *) 

WriteString ('There were *); 
WriteCard (count, 0); WriteString 
(* primes.*) ; 

END MSIEVE. 


(continued) 


BYTE LISTINGS SUPPLEMENT 201 










March 


mtImef.mod 
TEXT 

"Modula-2 System for Z80 CP/M." See mfI Iecpy.mod. 


MODULE MTIMEF; (* times floating point 

operations ♦) 

FROM Terminal IMPORT 

Write, WriteLn, WriteStrlng; 

FROM MathLib IMPORT 

sin, cos, arctan, In, exp; 

FROM ASCII IMPORT 
be I ; 

VAR 

x, y, z ; REAL; 
i : CARDINAL; 


PROCEDURE Delay (x ; CARDINAL); 

(* variable delay, x in milliseconds *) 

VAR 

i, j : CARDINAL; 

BEGIN 

FOR i :« 1 TO x DO 
FOR j 1 TO 18 DO 
END; 

END; 

END Delay; 


BEGIN 

x := 12.5; y :« 0.5; 

WriteString ('Blank'); WriteLn; 

Delay (500); 

Write (be I); 
i := 1; 

REPEAT 
z := y; 

I i ♦ 1; 

UNTIL i « 10000; 

Write (be I); 

Delay (4000); 

WriteString ('Addition'); WriteLn; 
Delay (500); 

Write (be I) ; 
i := 1; 

REPEAT 

z :■ x + y; 

1 :« i + 1; 

UNTIL i = 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Subtraction'); WriteLn; 
Delay (500); 

Write (bel); 
i := 1; 

REPEAT 

z :« x - y; 

i := i ♦ 1; 

UNTIL i = 10000; 

Write (be I) ; 

Delay (4000); 


WriteString ('Multiplication'); WriteLn; 
Delay (500); 

Write (bel); 
i 1; 

REPEAT 

z :* x * y; 

i :« 1 + 1; 

UNTIL i « 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Division'); WriteLn; 

Delay (500); 

Write (beI); 
i :*« 1 ; 

REPEAT 

z :» x / y; 

1 i + 1; 

UNTIL I - 10000; 

Wr 1 te (beI); 

Delay (4000); 

WriteString ('Sine'); WriteLn; 

Delay (500); 

Wr I te (be I); 
i :« 1; 

REPEAT 

r :« sin (y); 
i i + 1; 

UNTIL i = 1000; 

Write (be I); 

Delay (4000); 

WriteString (’Cosine'); WriteLn; 

Delay (500); 

Write (be I); 
i :« 1; 

REPEAT 

z :« cos (y); 
i i + 1; 

UNTIL i = 1000; 

Write (bel); 

Delay (4000); 

WriteString ('Arctangent'); WriteLn; 
Delay (500); 

Write (bel); 
i :» 1; 

REPEAT 

z := arctan (x); 
i :« i + 1; 

UNTIL i = 1000; 

Write (bel); 

Delay (4000); 

WriteString ('Natural Log'); WriteLn; 
Delay (500); 

Write (beI); 
i :« 1; 

REPEAT 

z := In (x); 
i : * i + 1; 

UNTIL i * 1000; 

Write (bel); 

Delay (4000); 
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WriteString ('Natural Antilog*); WriteLn; 
Delay (500); 

Write (be I); 
i s- 1; 

REPEAT 

z := exp (y); 


i := I + 1; 
UNTIL i = 1000; 
Write (beI); 
Delay (4000); 
END MTIMEF. 


mtimei.mod 
TEXT 

"Modula-2 System for Z80 CP/M." See mfiIecpy.mod. 


MODULE MTIMEI; 

FROM Terminal IMPORT 

(* standard module as defined by Wirth *) 
Write, WriteLn, WriteString; 

FROM ASCII IMPORT 
be I ; 

VAR 

x, y. z ; INTEGER; 
i ; CARDINAL; 


PROCEDURE Delay (x : CARDINAL); 

(* variable Delay, x in milliseconds *) 

VAR 

i, j : CARDINAL; 

BEGIN 

FOR i :* 1 TO x DO 
FOR J :« 1 TO 18 DO 
END; 

END; 

END Delay; 


BEGIN 

x :« 11; y :« 2; 

WriteString ('Blank'); WriteLn; 
Delay (500); 

Write (be I); 
i :« 1; 

REPEAT 

z :« y; 

1 := i + 1; 

UNTIL i = 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Addition'); WriteLn; 
Delay (500); 

Write (bel); 
i := 1; 

REPEAT 

2 :« x + y; 

i s- i + 1; 


UNTIL i - 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Subtraction'); WriteLn; 
Delay (500); 

Write (bel); 
i := 1; 

REPEAT 

z :» x - y; 

i := i + 1; 

UNTIL i - 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Multiplication'); WriteLn; 
Delay (500); 

Write (bel); 
i := 1; 

REPEAT 

z := x * y; 

i :» i + 1; 

UNTIL i - 10000; 

Wr i te (be I); 

Delay (4000); 

WriteString ('Division'); WriteLn; 

Delay (500); 

Write (be I) ; 
i :■ 1; 

REPEAT 

z :« x DIV y; 

I 2-1+1; 

UNTIL i - 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Modulus'); WriteLn; 

Delay (500); 

Write (bel); 
i 1; 

REPEAT 

z x MOD y; 

! I + 1; 

UNTIL i - 10000; 

Write (bel); 

Delay (4000); 

WriteString ('Good-bye...'); WriteLn; 

END MTIMEI. 


{continued) 
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mfI Iecpy.mod 

TEXT l 

Software Review: "Modula-2 System for Z80 CP/M," Brian R. Anderson. 

March, page 225. Also download mscreen.mod, msieve.mod, mtimef.mod, and 
mtImei.mod. 


MODULE MFILECPY; 

FROM SeqlO IMPORT 

FILE, FlleState, Open, Create, Close, Read, Write, EOF; 

FROM Terminal IMPORT 

ReadString, WriteLn, WriteString; 

FROM Strings IMPORT 
STRING; 


VAR 

inFILE, outFILE ; FILE; 

name, BAKname : STRING; (* file names *) 
c : CHAR; 


PROCEDURE MakeBAK (in : STRING; VAR out : STRING; tag : STRING); 
VAR 

i, j : CARDINAL; 


BEGIN 

i :« 0; 

WHILE (in[I] # 0C) AND (in[i] # *.*) DO 
out[i ] :■ in[i); 

INC (i); 

END; 


j := 0; 

WHILE tag[j] # 0C DO 
out[iJ :* tag[j1; 
INC (i); INC (j); 
END; 


out[i] := 
END MakeBAK; 


0C; (* add NULL terminator *) 


BEGIN 

WriteString (Tile Backup Utility*); WriteLn; WriteLn; 

WriteString ('Enter filename: '); 

ReadString (name); WriteLn; 

MakeBAK (name, BAKname, *.bak*); 

IF Create (outFILE. BAKname) * FileOK THEN 
IF Open (inFILE. name) = FileOK THEN 
WHILE NOT EOF (inFILE) DO 
Read (inFILE, c); 

Write (outFILE, c); 

END; 

IF (Close (inFILE) <> FileOK) OR (Close (outFILE) <> FileOK) THEN 
WriteString ('Error closing files...’); WriteLn; 

ELSE 

WriteString (BAKname); WriteString (' completed.*); WriteLn; 
END; 

ELSE 

IF Close (outFILE) <> FileOK THEN 
(* do nothing *) 

END; 
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WriteString ('Error creating new file...'); Writeln; 
END; 

ELSE 

WriteString ('Error opening file...*); WriteLn; 

END; 

END MFILECPY. 


I isting3.386 
TEXT 

Circuit Cellar; "Real-Time Clocks; A View Toward the 
Future." See listing!.386 for details. 


10 MTOP = MTOP - 30 (RESET MTOP POINTER) 

20 DBY(18H)=040H (ASSUME SMARTWATCH AT 4000H) 
30 CALL 6000H (INITIALIZE THE SYSTEM) 

40 REM NOW SET SMARTWATCH TIME 
50 FOR X-MTOP+24 TO MTOP+17 STEP -1 
60 READ C 
70 XBY(X)=C 


80 NEXT X 

85 REM ZZ/01/85 14;25;00.00 

90 DATA 85,11,01,05,14,25.00,00 
100 CALL 6003H (WRITE THE VALUES) 
110 CALL 6006H (READ THE VALUES) 
120 PRINT MTOP+18 (SECONDS COUNTER) 
130 GOTO 110 


I 1st i ng1.386 
TEXT 

Circuit Cellar; "Real-Time Clocks: A View Toward the Future," Steve Ciarcia. 
March, page 112. Also download Iisting2.386, and Iisting3.386. 


100 DIM N(200) ; DIM M(200) 

110 REM 

120 REM REV 1.5 11/8/85 

130 REM 5832 REAL TIME CLOCK FOR BCC-52 I/O PORT 
140 REM 

150 PI-51200 : P2-51201 : P3-51202 : P4-51203 

155 REM SET 8255 PORT A AS INPUT AND B&C AS OUTPUT 
160 XBY(P4)=90H 

170 REM PORT B IS ADDRESS AND PORT C IS CONTROL BUS 

180 PRINT "ENTER 0 TO SET TIME OR 1 TO READ TIME", : INPUT A 

190 ON A GOSUB 350,220 

200 GOTO 180 

210 GOTO 145 

220 REM READ 13 5832 REGISTERS 

230 XBY(P3)*20H : REM SET READ MODE 

240 FOR A=0 TO 12 

250 XBY(P2)=A : N(A)-XBY(P1) 

260 NEXT A 

270 REM DISPLAY CONTENTS 

280 PRINT "DATE ", 

290 PRINT N(10)*10+N(9),"/",N(8)*10+N(7),"/",N(12)*10+N(11) 

300 PRINT "TIME ", 

310 IF N(5)>«8 THEN N(5)-N(5)-8 

320 PRINT (N(5)*10)+N(4)," : ".(N(3)*10)+N(2)." : ",(N(1)*10)+N(0) 

330 PRINT 

340 RETURN 

350 REM SET TIME 

360 XBY(P4)=80H : REM SET PORTS A.B.&C AS OUTPUT 

370 REM MSB OF REG 5 12(0)/24(1) HRS k MSB-1 AM(0)/PM(1) 

380 FOR A=0 TO 12 

390 PRINT "REGISTER",A, : INPUT X 

400 XBY(P2)«A : XBY(P1)«X 

405 REM WRITE STROBE 

410 XBY(P3)-10H : XBY(P3)-50H : XBY(P3)«10H : XBY(P3)«00H 

420 NEXT A 

430 XBY(P4)«90H : REM RESTORE READ PORT SETTINGS 

440 PRINT 

450 RETURN 


(continued) 


BYTE LISTINGS SUPPLEMENT 205 











March 


list)092.386 
TEXT 

Circuit Collar: "Real-Time Clocks: A View Toward the 
Future." See llstingl.386 for details. 


E 

10 REM APPLICATION PROGRAM USING ONLY BASIC TO DEMONSTRATE 

20 REM SMARTWATCH REAL TIME CLOCK ON BCC52 COMPUTER CONTROLLER BOARD 

30 CLEAR 

40 STRING 200,15 

50 $(1)-"SUNDAY" 

60 $(2)«"MONDAY" 

70 $(3)-"TUESDAY" 

80 $(4)-"WEDNESDAY" 

90 $ ( 5) -"THURSDAY" 

100 $(6)=“FRIDAY" 

110 $(7)«"SATURDAY" 

120 REM 

130 REM ************* MAIN MENU ******************************************** 
140 REM 

150 PRINT "0-READ DATE/TIME 1-ENTER NEW DATE/TIME ?" 

160 G-GET 

170 GOSUB 1350 : REM GET NUMBER 0-9 

180 PRINT CHR(18),CHR(27),"Y" : REM CLR 4 HOME TERMITE TERMINAL 

190 IF G=0 THEN GOSUB 790 : REM READ 4 DISPLAY DATE/TIME INFO 
200 IF G=1 THEN G0SU8 250 : REM GATHER 4 SAVE NEW DATE/TIME INFO 

210 GOTO 150 
220 REM 

230 REM ************* GATHER $ SAVE NEW DATE/TIME INFO ******************* 
240 REM 

250 J=XBY(4000H) : REM SAVE BYTE LOCATED IN 4000H TO REPLACE WHEN OONE 

260 GOSUB 1420 : REM SENO PATTERN RECOGNITION CODES 

270 PRINT "ENTER DATE MMDDYY" 

280 G-GET 

290 FOR Z-6 TO 8 : REM USE G(6) FOR MM. G(7) FOR DD. G(8) FOR YY 

300 GOSUB 1350 : REM GET NUMBER 0-9 

310 PRINT G. : REM ECHO NUMBER 0-9 

320 H-G*16 : REM STORE NUMBER IN UPPER NIBBLE 

330 GOSUB 1350 

340 PRINT G. 

350 G(Z)=H+G : REM COMBINE NUMBERS 1 IN UPPER NIBBLE, 1 IN LOWER NIBBLE 

360 NEXT Z 

370 PRINT 

380 G=G(6) : REM 

390 G(6)=G(7) : REM SWAP 6 & 7, NOW 6.7,8 IN DD/MM/YY 

400 G(7)-G : REM 

410 G(1)=0 : REM SET TENTHS k HUNDREDS OF A SECOND = 0 

420 PRINT "DAY OF THE WEEK SUN=0 MON-1 TUE=2 WED-3 THU=4 FRI=5 SAT-6 ?" 

430 G-GET 

440 GOSUB 1350 

450 PRINT G 

460 PRINT 

470 G(5)=G.0R.10H : REM OR BIT4 TO IGNORE RESET FROM PIN 1 

480 PRINT "ENTER TIME HHMMSS" 

490 G-GET 

500 FOR Z-4 TO 2 STEP -1 : REM USE G(4) FOR HH. G(3) FOR MM, G(2) FOR SS 

510 GOSUB 1350 

520 PRINT G, 

530 H=G*16 

540 GOSUB 1350 

550 PRINT G, 

560 G(Z)«H+G 

570 NEXT Z 

580 PRINT 

590 PRINT "IS THE TIME IN 0=24 HOUR FORMAT 1=12 HOUR FORMAT ?" 

600 G=GET 

610 GOSUB 1350 

620 IF Gol THEN 680 : REM IF NOT 1 THEN JUMP 

630 G(4)=(G(4).0R.80H) : REM OR BIT7 TO INDICATE 12 HOUR FORMAT 

640 PRINT "IS IT 0=AM 1=PM ?" 

650 G-GET 

660 GOSUB 1350 

670 IF G»1 THEN G(4)=(G(4).OR.20H) : REM OR BIT5 TO INDICATE PM 
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680 REM HOLD FOR TIME SYNCRONIZATION 

690 PRINT “HIT ’0* TO GO SET THE NEW DATE/TIME" 

700 GOSUB 1350 

710 IF G<>0 THEN 700 

720 GOSUB 1530 : REM STORE DATE/TIME INFO TO SMARTWATCH 

730 XBY(4000H)=J : REM REPLACE BYTE TO 4000H 

740 G=0 

750 RETURN 

760 REM 

770 REM ************ READ & DISPLAY DATE/TIME **************************** 

780 REM 

790 J=XBY(4000H) 

800 GOSUB 1420 : REM SEND PATTERN RECOGNITION COOES 

810 GOSUB 1230 : REM READ SMARTWATCH REGISTERS 

820 PRINT "TODAY IS " , $ ( (G(5 ).AND.7H)+1) : REM STRIP OFF DAY OF WEEK 

830 $(8)«" / / REM INITIALIZE DATE STRING 

840 Z*7 : REM USE G(7) MM REGISTER 

850 X*1 : REM PLUG CHARACTERS INTO STRING STARTING AT POSITION 1 

860 GOSUB 1630 : REM GET 2 CHARACTERS FROM G(Z) AND PLUG INTO STRING $(8) 

870 Z-6 

880 X=4 

890 GOSUB 1630 

900 Z=8 

910 X*7 

920 GOSUB 1630 

930 $(9)«$(8) : REM SAVE IT IN $(9) FOR ANY FUTURE USE 

940 PRINT $(9) 

950 $(8" : REM INITIALIZE TIME STRING 

960 G(9)«G(4) 

970 IF fGm.AND.80H)=0 THEN 1020 : REM IF BIT7=0 THEN 24 HR FORMAT. JUMP 
980 IF (G(4).AND.20H)=0 THEN ASC($(8),13)«41H : REM IF BIT5 = 0. PLUG A 
990 IF (G(4).AND.20H)=20H THEN ASC($(8),13)«50H : REM IF BIT5 SET. PLUG P 
1000 ASC($(8).14)-4DH : REM PLUG M 

1010 G(9)«(G(4).AND.1FH) : REM STRIP OFF FORMAT FROM HOUR REGISTER 

1020 Z-9 

1030 X*1 

1040 GOSUB 1630 

1050 ASC($(8),3)=3AH : REM PLUG IN THE CHARACTER FOR COLON 

1060 Z*3 

1070 X=4 

1080 GOSUB 1630 

1090 ASC($(8),6)=3AH 

1100 Z=2 

1110 X-7 

1120 GOSUB 1630 

1130 Z«1 

1140 X*10 

1150 GOSUB 1630 

1160 PRINT $(8) 

1170 XBY(4000H)=J 

1180 G=0 

1190 RETURN 
1200 REM 

1210 REM ************ READ SMARTWATCH REGISTERS ************************* 

1220 REM 
1230 FOR Z=1 TO 8 
1240 G(Z)=0 

1250 FOR X*=1 TO 8 

1260 G=(XBY(4000H).AND.1) : REM G - BIT0 

1270 IF G=0 THEN 1290 : REM BIT = 0, DON'T ADD ANYTHING TO REGISTER BYTE 

1280 G(Z)-G(Z)+(2**(X-1)) : REM BUILD REGISTER BYTE FROM BITS RECEIVED 

1290 NEXT X 

1300 NEXT Z 

1310 RETURN 

1320 REM 

1330 REM ************ GET NUMBER 0-9 ************************************ 

1340 REM 
1350 G-GET 

1360 IF G<48.0R.G>57 THEN 1350 
1370 G-G-48 : REM ASC TO 0-9 

1380 RETURN 
1390 REM 

1400 REM ************ INITIALIZE PATTERN RECOGNITION CODES ************** 

1410 REM 
1420 G(1)*0C5H 
1430 G(2)«3AH 
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1440 

G(3)-0A3H 

1450 

G(4)=5CH 

1460 

G(5)«0C5H 

1470 

G(6)«3AH 

1480 

G(7)=0A3H 

1490 

G(8)-5CH 


1500 REM 

1510 REM ************ SEND REGISTERS TO SMARTWATCH *********************** 

1520 REM 

1530 FOR Z-1 TO 8 

1540 FOR X*1 TO 8 

1550 IF (G(Z).AND.(2**(X-1)))<>0 THEN G-1 ELSE G-0 : REM STRIP OFF BIT 

1560 XBY(4000H)=G : REM SEND BIT TO SMARTWATCH 

1570 NEXT X 

1580 NEXT Z 

1590 RETURN 

1600 REM 

1610 REM ************ GET 2 CHARACTERS FROM G(Z) REGISTER, PLUG $(8) @ X 
1620 REM V 9 

1630 G«INT(G(Z)/16) 

1640 ASC($(8),X)«G+48 

1650 ASC($(8),X+1)-G(Z)-(G*16)+48 

1660 RETURN 

1670 REM 

1680 REM ************ END *********************************************** 


explorer.txt 
TEXT 

Programming Insight. "Macintosh Explorer," Olav Andrade. 
March, page 145. 


0EM 

REM 

REM 

REM 

REM 

REM 

REM 


This program is to be made available at no charge. 

Macintosh Explorer 

Author: 0. Andrade CServe: 74726,1177 

14 Shanley St. 

Kitchener, Ontario 

Canada 

N2H 5N8 


DEFINT A-Z:GOSUB 550 
CLS:0N ERROR GOTO 4200:GOTO 2560 
230 C2#=A0#:GOSUB 370:W=N 
FOR 16=0 TO 3 
C2#=C2#+2 

GOSUB 370:W0(I6)=N 
U0(I6)«F 
NEXT 16 
N6=F:N3=F 

N2=W0(0):N4=W0(1):GOSUB 420 
K=0:WHILE K<4 AND U0(K):K=K+1:WEND 
A0#=A0#+2+2*K 
RETURN 

370 N=PEEK(C2#):IF N>127 THEN N=N OR &HFF00 
N=N*256+PEEK(C2#+1)rRETURN 


420 14=0:WHILE((I4<06)AND(W AND 02(14))<>03(14)):14=14+1-WEND 
IF I4>=06 GOTO 500 


S4=0:04$="":O0$=O1$(I4):B=F 
IF 05(I4)>0 THEN ON 05(I4)G0SUB 
1460,1470,1560,1480.1490,1520,1720.1730,1740,1750 
IF O5(I4)>10 THEN ON O5(I4)-10 GOSUB 
2230,1770,1800,1570,1840.1870,1880,1900,1930,1970 
IF 05(I4)>20 THEN ON O5(I4)-20 GOSUB 
1990,2300.2020.2030,2050,2080,1600,2120,2320,1680 
IF 05(I4)>30 THEN ON O5(I4)-30 GOSUB 1940,2360,2370,2380.2390,2400 
IF NOT B THEN PRINT A0#;" ";O0$;" ";04$:G0T0 510 

510 RETURN^ 1 " ^ $" ;HEX$(W) :FOR 16=0 TO 3:U0( I6)=F :NEXT 


550 06-71:DIM 02(06),03(06),01$(06),05(06) 

FOR 1=0 TO 06-1:READ 01$(I).02(1).03(1).05(1):NEXT 

DATA reset, -1, 20080, 1. nop, -1, 20081. 1, stop, -1. 
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20082, 1. rte, -1, 20083, 1 

DATA rts, -1. 20085, 1, trapv, -1, 2008$, 1, rtr, -1, 20087, 1, 

swop, -8, 18496, 2 

DATA "ext.w", -8, 18560, 2, "ext. I", -8, 18624, 2, link, -8, 20048, 

3, unlk, -8, 20056, 4 


DATA 
DATA 
DATA 
DATA 
DATA 

32512, 10 
DATA 

19584, 11 
DATA 
18944,14 
DATA 
DATA 
OATA 
30 


move, -8, 20064, 35, move, -8, 20072, 36, trop, -16, 20032, 5 
nbcd, -64, 18432, 6. pea. -64, 18496, 6, move, -64, 16576, 32 
move, -64, 17600, 34, move, -64, 18112, 33, tos, -64, 19136, 6 
jsr, -64, 20096, 6. jmp, -64, 20160, 6, exg, -3592, -16064, 7 
exg, -3592, -16056, 8, exg, -3592, -15992, 9. sbcd, -3600, - 

abed, -3600, -16128, 10, movem, -128, 18560, 11, movem, -128, 

db, -3848, 20680, 12, stotBit, -256, 2048, 13, tst, -256, 

cIr, -256, 16896, 14, neg, -256, 17408, 14, or. -256, 0, 30 
not. -256, 17920, 14, and, -256, 512, 30. bsr, -256, 24832, 15 
sub, -256, 1024, 30, empm, -3784, -20216, 16, add, -256, 1536, 


DATA 

14 

eor, 

-256, 2560, 30. cmp, -256, 3072, 

30, negx, 

-256, 16384, 

DATA 

16192,19 

subx. 

, -3792. -28416,17, 

movep, -4040, 

8, 18, mulu, -3684, - 

DATA 

32576, 19 

mu 1 s , 

, -3648, -15936, 19, 

chk, -3648, 

16768, 19, 

dlvu, -3648, - 

DATA 

12032, 17 

di vs, 

, -3648, -32320, 19, 

lea, -3648, 

16832, 31, 

addx, -3792, - 

DATA 

3840, 256, 22 

memShifts, -1856, -8000, 

20, s, -3904 

, 20672, 21 

, dynBit, - 

DATA 

eor, 

-3840, -20224, 23. 

addq, -3840, 

20480, 24, 

subq, -3840, 


20736, 24 
DATA 
4096, 27 
DATA 

-20480, 28 
DATA 

4096, 12288, 27 

DATA dataRegShifts, -4096, -8192, 29, and. -4096, -16384, 28 

A5=ASC( " 0 " ) :A6-ASC("a"):F=0:T-NOT F 
DIM S3$(3):S3$(0)-".b":S3$(1)-".w":S3$(2)-".I" 

DIM W0(3).U0(3),C0$(16),B3$(4),S2$(4),M(16) 


moveq, -3840, 28672, 25, b. -4096, 24576. 26. "move.b", -4096, 
sub, -4096, -28672, 28, "move.I", -4096, 8192, 27, cmp. -4096, 
or, -4096, -32768, 28. add. -4096, -12288, 28, "move.w". - 


C0$(0)-“t":C0$(1)-"f":C0$(2)-"hl":C0$(3)«"Is" 
C0$(4)="cc“:C0$(5)«"cs":C0$(6)«"ne":C0$(7)="eq" 
C0$(8)-"vc":C0$(9)-"vs":C0$(10)-"pl":C0$(11)-"m 
C0$(12)-"ge":C0$(13)-"lt":C0$(14)-"gt":C0$(15)« 
B3$(0)-"btst":B3$(1)-"bchg":B3$(2)-"bcIr":B3$(3)-" 
S2$(0)-"as":S2$(1)-"Is":S2$(2)-"rox":S2$(3)-"ro" 
CALL TEXTFONT(4):CALL TEXTSIZE(9) 

B5-85:B4-15:S«278 


bset" 


DIM 18(4):I.-5:100-5:I8(0)-I00:18(1)-I.:I8(2)-I8(0)+B4:I8(3)-I8(1)+B5 

DIM M0(4):M2-I.+B5+20:M3-I00:M0(0)-M3:M0(1)-M2:M0(2)-M0(0)+B4:M0(3)=M0(1)+B5 

DIM 

D7(4):D.-M2+B5+20:D00-I00:D7(0)«D00:D7(1)-0.:D7(2)=D7(0)+B4:D7(3)»D7(1)+B5 
DIM D(4):D1«I.:02-100+84+5:O(0)=D2:D(1)-D1:D(2)-D(0)+B4:D(3)-D(1)+B5 
DIM 

D02(4):D04-M2:D05-D2:D02(0)=D05:D02(1)-D04:D02(2)-D02(0)+B4:D02(3)=D02(1)+B5 
DIM L0(4):L2»D.:L3«D2:L0(0)=L3:L0(1)=L2:L0(2)»L0(0)+B4:L0(3)-L0(1)+B5 
DIM A1(4):A3-D.+B5+20:A4-D2:A1(0)-A4:A1(1)-A3:A1(2)=A1(0)+84:A1(3)=A1(1)+B5 
DIM V(4):V2«A3+B5+10:V3=D2:V(0)=V3:V(1)-V2:V(2)»V(0)+B4:V(3)=V(1)+B5 
DIM Cl(4):C1(0)-0:C1(1)=0:C1(2)-V(2)+4:C1(3)=V(3) 

DIM 101(1),I7(1):N1-1 

DIM D9(310):D5-0:D3-0:B2“52:FOR 15=0 TO 27:READ D9(I5):NEXT 
DATA &h4e56, 0, 16890, 50, 12668, -5, 24 
DATA 12668, 1, 22. 12668, 1, 44, 8572, 0, 0, 46, 8572, 0 
DATA 512, 36, 17402, 60, 8521, 32. &ho002, &h4e5e, &h4e75 
U=0:19-1:MI-2:D8-3:00-4 


D03-5:A2-6:V0-7:L1=8 


SI-Ml:RETURN 
1100 E$»"“ 

ON M4+1 GOSUB 1130.1140,1150.1160.1170,1180,1190.1250 
RETURN 

1130 E$="d"+CHR$(R0+A5):RETURN 
1140 E$-"o"+CHR$(R0+A5):RETURN 
1150 E$«"(a"+CHR$(R0+A5)+")":RETURN 
1160 E$="(a"+CHR$(R0+A5)+")+":RETURN 
1170 E$="-(o“+CHR$(R0+A5)+“)":RETURN 
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1180 E$-STR$(N2)+" (o"+CHR$(R0+A5)+")":N6«T:RETURN 
1190 IF N2<0 THEN E$«"o"ELSE E$="d" 

E$-E$+CHR$((N2 AND 4H7000)\4096+A5) 

IF N2 AND 4H800 THEN E$-E$+ M .l“ 

E$»" (a"+CHR$(R0+A5)+", “+E$+")" 

IF(N2 AND 4H80)THEN E$-STR$((N2 AND 4HFF)0R 4HFF00)+E$ELSE E$»STR$(N2 AND 
4HFF)+E$ 

N6-T:RETURN 

1250 ON R0+1 GOSUB 1280.1290.1310.1320.1380.1270.1270.1270 
RETURN 

1270 B-T:RETURN 

1280 E$-"($"+HEX$(N2)+")":N6=T:RETURN 
1290 GOSUB 1410:E$="($"+HEX$(N2)+I3$+")" 

N6»T:N3=T:RETURN 

1310 E$=STR$(N2)+"(pc)":N6-T:RETURN 
1320 IF N2<0 THEN E$-'*o"ELSE E$="d" 

E$=E$+CHR$((N2 AND 4H7000)\4096+A5) 

IF N2 AND 4H800 THEN E$-E$+".l" 

E$“"(pc, "+E$+”)" 

IF(N2 AND 4H80)THEN E$-STR$((N2 AND 4HFF)0R 4HFF00)+E$ELSE E$«STR$(N2 AND 
4HFF)+E$ 

N6-T:RETURN 

1380 E$="#$"+HEX$(N2):N6«T 
IF S4=2 THEN GOSUB 1410:E$«E$+I3$:N3«T 
RETURN 

1410 I3$-HEX$(N4):IF LEN(I3$)<4 THEN I3$=STRING$(4-LEN(13$).“0 M )+I3$ 

1420 RETURN 
1460 04$-"":RETURN 

1470 04$="d"+CHR$((W AND 7)+A5):RETURN 
1480 04$="o“+CHR$((W AND 7)+A5):RETURN 
1490 IF((W AND 15)>9)THEN 1510 
04$-CHR$((W AND 15)+A5):RETURN 
1510 04$=CHR$((W AND 15)+A6-10):RETURN 
1520 M4=(W ANO &H38)\8:R0=(W AND 7) 

GOSUB 1100:O4$-E$:IF N6 THEN U0(0)-T 
IF N3 THEN U0(1)-T 
RETURN 

1560 04$-"o”+CHR$((W AND 7)+A5)+". "+STR$(N2):U0(0)-T:RETURN 
1570 S4=(W AND &HC0)\64:M4-(W AND 4H38)\8:R0-(W AND 7):G0SUB 
1100:04$=E$:O0$=O0$+S3$(S4) 

1580 IF N6 THEN U0(0)«T:IF N3 THEN U0(1)-T 
1590 RETURN 

1600 M4«(W AND 4H38)\8:R0»(W AND 7) 

1610 IF(W AND 4HF000)»4H1000 THEN S4-0ELSE IF(W AND 4HF000)-4H2000 THEN 

S4-2ELSE S4=1 

1620 GOSUB 1100:S0$=E$ 

1630 IF N6 THEN U0(0)-T:N6-F:IF N3 THEN U0(1)=T:N3=F:N2=W0(2):N4=W0(3)ELSE 
N2-N4:N4-W0(2) 

1640 M4-(W AND 4H1C0)\64:R0-(W AND 4HE00)\512:GOSUB 1100:O4$=S0$+". “+E$ 
1650 IF N6 THEN IF U0(0)THEN IF U0(1)THEN U0(2)-TELSE U0(1)-TELSE U0(0)-T 
1660 IF N3 THEN IF U0(1)THEN IF U0(2)THEN U0(3)-TELSE U0(2)-TELSE U0(1)“T 
1670 RETURN 

1680 S4-(W AND 4HC0)\64:M4-(W AND 4H38)\8:R0-(W AND 
7):O4$-"#$"+HEX$(N2):U0(0)-T:IF S4<>2 THEN 04$-04$+", "ELSE GOSUB 
1410:N3-T:04$-04$+I3$+“, “ 

1690 IF((W AND 4H3F)«4H3C)THEN 04$-04$+"sr":GOTO 1700ELSE IF NOT N3 THEN 
N2=W0(1):N4=W0(2)ELSE U0(1)-T:N3-F:N2-W0(2):N4-W0(3) 

1695 GOSUB 1100:04$=04$+E$ 

1700 O0$=O0$+S3$(S4):IF N6 THEN IF NOT U0(1)THEN U0(1)-T:IF NOT N3 THEN 
RETURNELSE U0(2)=TELSE U0(2)=T:IF N3 THEN U0(3)-T 
1710 RETURN 

1720 04$="d"+CHR$((W AND 4HE00)\512+A5)+". d"+CHR$((W AND 7)+A5):RETURN 
1730 04$="a”+CHR$((W AND 4HE00)\512+A5)+". o"+CHR$((W AND 7)+A5):RETURN 
1740 04$="d"+CHR$((W AND 4HE00)\512+A5)+". a"+CHR$((W AND 7)+A5):RETURN 
1750 IF(W AND 8)THEN 1760ELSE 04$-"d"+CHR$((V» AND 7)+A5)+", d"+CHR$((W AND 
4HE00)\512+A5):RETURN 

1760 04$«"-(a"+CHR$((W AND 7)+A5)+"), -(a"+CHR$((W AND 
4HE00)\512+A5)+")":RETURN 

1770 O0$=O0$+C0$((W AND 4HF00)\256):04$="d"+CHR$((W AND 7)+A5)+", $" 

1780 U0(0)=T:IF N2<0 THEN 04$=04$+STR$(N2)ELSE 04$=04$+" +"+STR$(N2) 

1790 RETURN 

1800 O0$=B3$((W AND 4H60)\64):M4=((W AND 4H38)\8):R0=(W AND 7) 

1810 U0(0)=T:04$= ")jl"+STR$((4H1F AND N2)) + ". " :N2=N4:N4=W0(2) :GOSUB 
1100:04$=04$+E$ 

1820 IF N6 THEN U0(1)=T:IF N3 THEN U0(2)«T 
1830 RETURN 

1840 IF(W AND 128)THEN O0$=O0$+".s": 04$-"$ "+STR$((W AND 4HFF)0R 4HFF00)+" 
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"+STR$(A0#+2-(W AND 4HFF)):RETURN 

1850 IF(W AND 4HFF)=0 THEN U0(0)=T:IF N2<0 THEN 04$="$ "+STR$(N2)+"; 
"+STR$(A0#+4+N2):RETURN ELSE 04$="$ +"+STR$(N2)+"; "+STR$(A0#+4+N2):RETURN 

1860 O0$=O0$+".s“: 04$="$ +"+STR$(W AND 4HFF)+"; "+STR$(A0#+2+(W AND 

&HFF)):RETURN 

1870 O0$=O0$+S3$((W AND 4HC0)\128):04$=“(a"+CHR$((W AND 7)+A5)+")+, 

(o"+CHR$((W AND 4HE00)\512+A5)+")+":RETURN 

1880 IF(W AND 8)THEN 1890ELSE 04$="d"+CHR$((W AND 7)+A5)+". d"+CHR$((W AND 
4HE00)\512+A5):RETURN 

1890 04$="-(a"+CHR$((W AND 7)+A5)+"), -(a"+CHR$((W AND 
4HE00)\512+A5)+")":RETURN 

1900 U0(0)=T:IF(W AND 64)THEN O0$=O0$+".I"ELSE O0$=O0$+".w" 

1910 IF(W AND 128)THEN 04$="d"+CHR$((W AND 

4HE 00)\512+A5) + "."+STR$(N2)+"(a"+CHR$((W AND 7)+A5)+")":RETURN 
1920 04$=STR$(N2)+“(a"+CHR$((W AND 7)+A5)+"), d"+CHR$((W AND 
4HE00)\512+A5):RETURN 

1930 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:O4$=E$+". d"+CHR$((W AND 
4HE00)\512+A5):G0T0 1950 

1940 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:04$=E$+". a"+CHR$((W AND 
4HE00)\512+A5) 

1950 IF N6 THEN U0(0)=T:IF N3 THEN U0(1)=T 
1960 RETURN 

1970 O0$=S2$((W AND 4H600)\512):IF(W AND 256)THEN O0$=O0$+"I"ELSE O0$=O0$+"r" 
1980 M4=(W AND 4H38)\8:R0=(W AND 7):GOSUB 1100:O4$=E$:GOSUB 1580:RETURN 
1990 O0$=O0$+C0$((W AND 4HF00)\256):M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 
1100:04$=E$:GOSUB 1580:RETURN 

2000 O0$=B3$((W AND 4H60)\64):04$="d"+CHR$((W AND 4HE00)\512+A5)+". - 
2010 M4=(W AND 4H38)\8:R0=(W AND 7):G0SU8 1100:04$=04$+E$:GOSUB 1580:RETURN 
2020 04$= *d”+CHR$((W AND 4HE00)\512+A5):GOTO 2040 

2030 t0=(W AND 4HE00)\512: IF t0=0 THEN 04$="#8“ ELSE O4$="#"+CHR$(t0+A5) 

2040 S4=(W AND 4HC0)\64 :O0$=O0$+S3$(S4):M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 
1100:04$=04$+", "+E$:GOSUB 1580:RETURN 
2050 04$=". d"+CHR$((W AND 4HE00)\512+A5) 

2060 IF(W AND 128)THEN 04$="#"+STR$((W AND 4HFF)0R 4HFF00)+O4$:RETURN 
2070 04$="#"+STR$(W AND 4HFF)+04$:RETURN 

2080 O0$=O0$+C0$((W AND 4HF00)\256):IF(W AND 128)THEN O0$=O0$+".s“: 
04$= M $"+STR$((W AND 4HFF)0R 4HFF00)+"; "+STR$(A0#+2-(W AND 4HFF)):RETURN 

2090 IF(W AND 4HFF)=0 THEN U0(0)=T:O0$=O0$+".w": IF N2<0 THEN 04$="$ 
"+STR$(N2)+"; "+STR$(A0#+4+N2):RETURN ELSE 04$="$ +"+STR$(N2)+"; 

"+STR$(A0#+4+N2):RETURN 

2100 O0$=O0$+".s“: 04$="$ +"+STR$((W ANO 4HFF))+“; "+STR$(A0#+2+(W AND 

4HFF)):RETURN 
2110 RETURN 

2120 0=(W AND 4HE0)\64+1:0N 0 GOSUB 2160.2170.2180.2160,2170.2180.2170.2180 
2130 ON 0 GOSUB 2190.2190.2190,2200,2200.2200.2210.2210 
2140 IF N6 THEN U0(0)=T:IF N3 THEN U0(1)=T 
2150 RETURN 

2160 O0$=O0$+".b":S4=0:RETURN 
2170 O0$=O0$+".w":S4=1:RETURN 
2180 O0$=O0$+".I":S4=2:RETURN 

2190 GOSUB 2220:04$=E$+", d"+CHR$((W AND 4HE00)\512+A5):RETURN 
2200 GOSUB 2220:04$="d"+CHR$((W AND 4HE00)\512+A5)+". "+E$:RETURN 
2210 GOSUB 2220:O4$»E$+", o"+CHR$((W AND 4HE00)\512+A5):RETURN 
2220 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:RETURN 
2230 IF(W AND 64)THEN O0$=O0$+“.I":S4=2ELSE O0$=O0$+".w":S4=1 
2240 R2=N2:U0(0)=T:N2=N4:N4=W0(2) 

2250 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100 
2260 IF N6 THEN U0(1)=T:IF N3 THEN U0(2)=T 

2270 IF M4=4 THEN FOR 11=1 TO 15:M(I1)=2~(15-I1):NEXT:M(0)=-327681ELSE FOR 
11=0 TO 14:M(I1)=2*I1:NEXT:M(15)»-32768! 

2280 GOSUB 2440:IF(W AND 4HF00)=4H800 THEN 04$=04$+'\ "+E$ELSE 04$=E$+", "+04$ 
2290 RETURN 

2300 04$="d"+CHR$((W AND 4HE00)\512+A5) 

2310 O0$=B3$((W AND 4HC0)\64):M4=((W AND 4H38)\8):R0=(W AND 7):G0SUB 
1100:O4$=O4$+", "+E$:GOSUB 1580:RETURN 

2320 IF(W AND 32)THEN 04$="d"+CHR$((W AND 4HE00)\512+A5)ELSE t0=(W AND 
4HE00)\512: IF t0=0 THEN 04$=#8" else O4$="#"+chr$(t0+A5) 

2330 04$=04$+", d"+CHR$((W AND 7)+A5) 

2340 O0$=S2$((W AND 4H18)\8):IF(W AND 256)THEN O0$=O0$+"I"ELSE O0$=O0$+"r" 

2350 O0$=O0$+S4$((W AND 4HC0)\64):RETURN 
2360 GOSUB 1520:O4$="sr, "+04$:RETURN 
2370 GOSUB 1520:O4$=O4$+", sr":RETURN 
2380 GOSUB 1520:O4$=O4$+", ccr":RETURN 
2390 GOSUB 1480:04$=04$+", usp":RETURN 
2400 GOSUB 1480:O4$="usp, "+04$:RETURN 
2410 

2420 REM return movem operand (extension word decoding) 
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2430 

2440 FOR 11-0 TO 1 

2450 F0-T:IF 11-0 THEN 04$-"“:R$-"d"ELSE R$-"o":IF 04$<>"”THEN IF M(15)<0 
AND(R2 AND &HFF00)<>0 THEN 04$-04$+"/"ELSE IF M(15)>0 AND(R2 ANO &HFF)<>0 THEN 
04$-04$+"/” 

2460 I2»0:WHILE I2<8 

2470 IF(M(I2+I1*8)AN0 R2)-0 THEN J0-I2+1:GOTO 2510 

2480 IF F0 THEN 04$-04$+R$+CHR$(I2+A5):F0=FELSE 04$-04$+“, "+R$+CHR$(I2+A5) 

2490 J0-I2+1:WHILE J0<8 AND(M(J0+I1*8)AND R2):J0-J0+1:WEND 

2500 IF(M(J0+I1*8-1)AND R2)AN0 J0>12+1 THEN O4$-O4$+"-"+R$+CHR$(J0+A5-1) 

2510 I2-J0:WEND 
2520 NEXT:RETURN 
2530 

2540 REM main loop 
2550 

2560 L-F:GOSUB 2950 
2570 WHILE NOT L 
2580 GOSUB 2650 

2590 ON R1 GOSUB 2820,2820,2820,3130.3230,3420.3450.2615 
2600 WENO 
2610 ENO 

2615 IF MOUSE(0)<>0 THEN L-T:SYSTEMELSE RETURN 
2620 

2630 REM determine mouse region 
2640 

2650 006-MOUSE(1)-I.:007-MOUSE(2)-I00:IF 0<=D06 AND D06<B5 AND 0C-D07 AND 
D07<=B4 THEN R1-I9:D01=MOUSE(0):RETURN 

2660 D06=MOUSE(1)-M2:D07=MOUSE(2)-M3:IF 0<=D06 AND D06<B5 AND 0<-D07 AND 
D07<=B4 THEN R1-M1:D01-MOUSE(0):RETURN 

2670 D06-MOUSE(1)-D.:D07-MOUSE(2)-D00:IF 0<-D06 AND D06<B5 AND 0<-D07 AND 
D07<-B4 THEN R1-08:D01-MOUSE(0):RETURN 

2680 D06-MOUSE(1)-D1:D07-MOUSE(2)-D2:IF 0<-D06 AND D06<B5 AND 0C-D07 AND 
D07<=B4 THEN R1=D0:D01=MOUSE(0):RETURN 

2690 D06-MOUSE(1)-D04:D07-MOUSE(2)-D05:IF 0C-D06 AND D06<B5 AND 0<=D07 AND 
D07<-84 THEN R1-003:001-MOUSE(0):RETURN 

2695 D06-MOUSE(1)-L2:D07-MOUSE(2)-L3:IF 0<-D06 AND D06<B5 AND 0<-D07 AND 
D07<-B4 THEN R1-L1:D01-MOUSE(0):RETURN 

2700 D06»MOUSE(1)-A3:007-MOUSE(2)-A4:IF 0<=D06 AND D06<B5 AND 0<-D07 AND 
O07<=B4 THEN R1-A2:D01-MOUSE(0):RETURN 

2710 D06»MOUSE(1)-V2:D07-MOUSE(2)-V3:IF 0<-D06 AND D06<85 AND 0<-D07 AND 
D07<=B4 THEN R1-V0:D01-MOUSE(0):RETURN 
2720 R1-U:D01-MOUSE(0):RETURN 
2730 

2740 REM select a path 
2750 

2760 ON SI GOSUB 2780.2790.2800 
2770 RETURN 

2780 CALL INV£RTRECT(VARPTR(18(0))):RETURN 
2790 CALL INVERTRECT(VARPTR(M0(0))):RETURN 
2800 CALL INVERTRECT(VARPTR(D7(0))):RETURN 
2810 

2820 IF MOUSE(0)=0 THEN RETURNELSE ON SI GOSUB 2880.2890.2900 
2830 ON R1 GOSUB 2850,2860,2870 

2840 S1-R1:WHILE MOUSE(0)=1:WEND:GOSUB 2940:RETURN 

2850 A0#-C:RETURN 

2860 A0#-M5#:RETURN 

2870 A0#=D4#:RETURN 

2880 C-A0#:RETURN 

2890 M5#=A0#:RETURN 

2900 D4#-A0#:RETURN 

2910 

2920 REM draw screen controls 
2930 

2940 CALL ERASERECT(VARPTR(C1(0))) , vvv 

2950 CALL M0VET0(I8(1)+10.I8(2)-5):PRINT"input";:CALL FRAMERECT(VARPTR(I8(0))) 
2960 CALL MOVETO(M0(1)+10,M0(2)-5):PRINT"memory";:CALL 

FRAMERECT(VARPTR(M0(0))) , , , 

2970 CALL MOVETO(D7(l)+10.D7(2)-5):PRINT"disk";:CALL FRAMERECT(VARPTR(D7(0))) 
2980 CALL MOVETO(D(1)+10,D(2)-5):PRINT"disassemble";:CALL 
FRAMERECT(VARPTR(D(0;)) 

2990 CALL MOVETO(D02(1)+10.D02(2)-5):PRINT"dump“;:CALL 
FRAMERECT(VARPTR(D02(0))) 

2995 CALL MOVETO(L0(1)+10,L0(2)-5):PRINT"quit";:CALL FRAMERECT(VARPTR(L0(0))) 
3000 CALL M0VET0(A1(1)+5,D7(2)-5):PRINT"address"; 

3010 CALL MOVETO(V(1)+5,D7(2)-5):PRINT"vaIue“; 

3020 CALL M0VET0(A1(1)+5,A1(2)-5):PRINT A0#;:CALL FRAMERECT(VARPTR(A1(0))) 

3030 CALL MOVETO(V(1)+5,V(2)-5):0N SI GOSUB 3050.3070,3080:PRINT VI$;:CALL 
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FRAMERECT(VARPTR(V(0))) 

3040 GOSUB 2760:RETURN 

3050 IF A0#>=N1 THEN V1$-"?"ELSE IF P THEN V1$=STR$(I01(A0#))ELSE 
V1$=STR$(I7(A0#)) 

3060 RETURN 

3070 C2#=A0#:GOSUB 370:VI$«STR$(N):RETURN 

3080 IF 0>A0|ff-D5*256 OR A0#-D5*256>«2*D3 THEN V1$="?”ELSE V1$=STR$(D9((A0#- 
D5*256)\2+B2)) 

3090 RETURN 
3100 

3110 REM mouse in disassemble button 
3120 

3130 IF MOUSE(0)=0 THEN RETURN 
3140 WHILE MOUSE(0)<>0 
3150 CALL MOVETO(0,S) 

3160 ON SI GOSUB 3730,230.3990: ’pick o path 
3170 GOSUB 2940:001-MOUSE(0) 

3180 WEND 
3190 RETURN 
3200 

3210 REM mouse in dump button 
3220 

3230 IF MOUSE(0)«0 THEN RETURN 
3240 WHILE MOUSE(0)<>0 
3250 CALL MOVETO(0,S) 

3260 ON SI GOSUB 3820,3330,4100 
3270 GOSUB 2940:001-MOUSE( 0 ) 

3280 WEND 
3290 RETURN 
3300 

3310 REM dump input path 
3320 

3330 I2$-'"':PRINT A0#;" 

3340 FOR 10=0 TO 15 

3350 I1=PEEK(A0#):IF I1<16 THEN PRINT”0";HEX$(I1);ELSE PRINT HEX$(I1); 

3360 IF ASC(" ")<I1 AND I1<128 THEN I2$-I2$+CHR$(I1)ELSE I2$-I2$+“." 

3370 A0#=A0#+1:NEXT 

3380 PRINT" ";12$:RETURN 

3390 

3400 REM mouse in address box 
3410 

3420 IF MOUSE(0)-0 THEN RETURN 

3430 CALL INVERTRECT(VARPTR(A1(0))):CALL M0VET0(A1(1)+5,A1(2)-5):B1-T:G0SUB 
3520 

3440 CALL INVERTRECT(VARPTR(A1(0))):D01-MOUSE(0):A0|»N5#:GOSUB 2940:RETURN 
3450 IF MOUSE(0)-0 THEN RETURN 

3460 CALL INVERTRECT(VARPTR(V(0))):CALL MOVETO(V(1)+5,V(2)-5):0N SI GOSUB 
3650,3645,3645 

3470 D01»MOUSE(0):IF N5#>32767 THEN N5#=N5#-65536! 

3480 VI-N5#:RETURN 

REM fetch keys: address or input 

3520 I1$-INKEY$:IF I1$=""THEN 3520 

3530 IF ASC(11 $)—13 THEN IF N0 THEN N5#—1*N5#:RETURNELSE RETURN 
3540 IF B1 THEN N5#-0:B1-F:H=F:N0=F:IF I1$-”$“THEN H-T:PRINT I1$;:G0T0 
3520ELSE IF I1$-”-"THEN PRINT 11$;:N0-T:GOTO 3520 

3550 IF“0"<«I1$AN0 I1$<«"9"THEN PRINT 11$;:A7-ASC(I1$)-ASC("0"):IF H THEN 
N5#-N5#*16+A7:G0T0 3520ELSE N5#-N5#*10+A7:GOTO 3520 

3560 IF"A“<«I1$AND I1$<-"F"THEN IF NOT H THEN BEEP:GOTO 3520ELSE PRINT 
11$;:N5#=N5#*16+ASC(11$)-ASC("A”)+10:GOTO 3520 

3570 IF"o"<«I1$AN0 I1$<-"f"AND H THEN PRINT 11$;:N5#-N5#*16+ASC(11$)- 
ASC("o")+10:GOTO 3520 
3580 BEEP:GOTO 3520 

3620 P-NOT P:IF P THEN ERASE 101:OIM 101(A0#+1)ELSE ERASE I7:DIM I7(A0#+1) 

3630 FOR 11-0 TO N1-1.-IF P THEN I01(I1)-I7(I1)ELSE I7(11 )-I01 (II) 

3640 NEXT:N1-A0#+1 
3645 RETURN 

REM disassemble input 
3650 IF A0#>-N1 THEN GOSUB 3620 

3660 B1-T:GOSUB 3520:N5#-N5#-65536!*INT(N5#/65536!):IF N5#>32767 THEN N5#-N5|- 
65536! 

3670 IF P THEN 101(A0#)-N5#ELSE I7(A0#)-N5# 

3680 A0#-A0#+1:GOSUB 2940:RETURN 

3730 IF A0#>N1 THEN W—1ELSE IF P THEN W-I01(A0#)ELSE W-I7(A0#) 

3740 P0-A0#:FOR 16-0 TO 3:P0«P0+1:IF P0>-N1 THEN W0(I6)—1ELSE IF P THEN 
W0(I6)«I01(P0)ELSE W0(I6)-I7(P0) 

3750 U0(I6)-F:NEXT:N6-F:N3-F 
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3760 N2-W0(0):N4-W0(1):GOSUB 420 

3770 K-0:WHILE K<4 AND A0#+1+K<N1 AND U0(K):K-K+1:WEND 
3780 A0#-A0#+1+K:RETURN 
REM dump disk 

3820 PRINT A0#;" M ;:12$-"":FOR 10-0 TO 7 

3830 IF A0#>=N1 THEN PRINT"????”;:I2$-I2$+“ M :GOTO 3880 

3840 IF P THEN 11-101(A0#)ELSE I1-I7(A0#) 

3850 I3$=HEX$(I1):IF LEN(I3$)-4 THEN PRINT I3$;ELSE PRINT STRING$(4- 
LEN(13$),"0");13$; 

3860 IF(ASC(" ”)<INT(I1\256))AND(INT(I1\256)<128)THEN 
I2$-I2$+CHR$(INT(I1\256))ELSE I2$-I2$+".« 

3870 IF ASC(“ ")<(I1 AND 255)AND(I1 AND 255)<128 THEN I2$=I2$+CHR$(II AND 
255)ELSE I2$=I2$+".“ 

3880 A0#=A0 j|l+1: NEXT: PR I NT " “;I2$ 

3890 RETURN 

REM fetch a disk sector 

3930 B0«F:D5»INT(A0#/512):IF 05 AND 64 THEN D9(15)-(05 OR &HFF80)*512ELSE 
D9(15)-(D5 AND tH7F)*512 

3935 D9(14)=05\128:D5-2*D5:D6I-VARPTR(D9(0)):CALL D6! 

3940 D3-(D9(28+20)*256+D9(28+21))\2:IF A0#-D5*256>-2*D3 THEN B0-T 

3950 RETURN 

REM disassemble disk 

3990 IF A0#-D5*256<0 OR A0#-D5*256>2*D3 THEN GOSUB 3930:IF B0 THEN BEEP:RETURN 
4000 P0=(A0#-256*D5)\2:A0#-2*P0+256*D5:W-D9(P0+B2) 

4010 FOR 16-0 TO 3:P0=P0+1:IF P0>-D3 THEN J#-A0#:A0#=A0#+2*P0:GOSUB 
3930:P0-0:A0#-J#:IF B0 THEN W0(I6)—1:GOTO 4030 
4020 W0(I6)=D9(P0+B2) 

4030 U0(I6)=F:NEXT:N6-F:N3-F 
4040 N2-W0(0):N4-W0(1):GOSUB 420 
4050 K-0:WHILE K<4 AND U0(K):K-K+1:WEND 
4060 A0#=A0#+2+2*K:RETURN 
REM dump disk 

4100 IF 2*INT(A0#/2)<>A0#THEN A0#-A0#-1 

4105 PRINT A0#;“ “;:I2$«“":FOR 10=0 TO 7 

4110 IF A0#-D5*256<0 OR A0#-D5*256>-2*D3 THEN GOSUB 3930:IF B0 THEN 
PRINT"????";:I2$«I2$+" ":GOTO 4160 

4120 I1=D9((A0#-D5*256)\2+82) 

4130 I3$»HEX$(I1):IF LEN(I3$)-4 THEN PRINT I3$;ELSE PRINT STRING$(4- 
LEN(13$),"0");13$; 

4140 IF(ASC("*")<INT(I1\256))AND(INT(I1\256)<128)THEN 
12$-12$+CHR$(INT(11\256))ELSE I2$-I2$+"." 

4150 IF ASC(" ")<(I1 AND 255)AND(I1 AND 255)<128 THEN I2$-I2$+CHR$(I1 AND 
255)ELSE I2$-I2$+“.“ 

4160 A0#=A0#+2:NEXT:PRINT" ";I2$ 

4170 RETURN 

REM expand the input path array 

4200 IF NOT(ERL=3620 AND ERR=7)THEN ON ERROR GOTO 0 

4210 BEEP:BEEP:P=NOT P:IF P THEN DIM I7(1)ELSE DIM 101(1) 

4220 GOSUB 2940:RESUME 2570 


diophant.bas 
TEXT 

Mathematical Equations, "Diophantine Equations," Robert T. Kurosaka, 
March, page 343. 


10 ****************************************** 

20 '* DIOPHANTINE EQUATION SOLVER * 

30 * * BY BOB KUROSAKA * 

40 '***************************************** 

50 CLS 

60 PRINT "This program solves equations of the form AX + BY = C," 

70 PRINT "where A, B, C, X, and Y are all integer values." 

80 PRINT :PRINT "Enter your equation as shown in the general form." 

90 PRINT "For example, enter 154X + 69Y « 5000 or 154X - 69Y = 5000." 

100 PRINT "Do not enter negative coefficients with parentheses." 

110 PRINT "That is, do NOT enter 154X + (-69Y) = 5000." 

120 PRINT :PRINT "The program will not work properly for the degenerate case" 
130 PRINT "where either A or B is 0." 

140 PRINT :INPUT "Enter equation";EQUATI0N$:A$-EQUATION$ 

150 REM DEFINE A READABLE FUNCTION FOR DISCARDING LEFTMOST CHARACTERS. 

160 DEF FNDROP.LEFT$(A$)=RIGHT$(A$,LEN(A$)-1) 

170 REM PARSING ROUTINE 
180 A*VAL(A$) 


214 


BYTE LISTINGS SUPPLEMENT 






March 


190 IF A=0 THEN A=1:IF LEFT$(A$,1)="-" THEN A—1 
200 A$=FNDROP.LEFT$(A$) 

210 DISCARD$=LEFT$(A$,1) 

220 WHILE DISCARD$<>"+" AND DISCARD$<>"-" 

230 A$=FNDROP.LEFT$(A$) 

240 DISCARD$=LEFT$(A$,1) 

250 WEND 
260 B=VAL(A$) 

270 IF B=0 THEN B=1:IF DISCARDS-"-" THEN B—1 
280 WHILE DISCARD$<>"-" 

290 AS-FNDROP.LEFTS(A$) 

300 DISCARD$-LEFT$(AS,1) 

310 WEND 

320 AS-FNDROP.LEFTS(A$) 

330 C-VAL(AS) 

340 IF AoINT(A) OR BoINT(B) OR CoINT(C) THEN 
PRINT "NOT A DIOPHANTINE EQUATION":GOTO 760 
350 REM END OF PARSING ROUTINE 
360 REM EUCLIDEAN ALGORITHM FOR FINDING GCD. 

370 REM FIRST, INITIALIZE THE TERMS FOR THE ALGORITHM 

380 IF ABS(A)>=ABS(B) THEN DIVIDEND-A:DIVISOR=B 

390 IF ABS(A)<ABS(B) THEN DIVISOR=A:DIVIDEND=B:SWAP.XY$="YES" 

400 REM USE ‘FIX’ INSTEAD OF *INT' TO TRUNCATE RATHER THAN ROUND NEGATIVE #s. 
410 QUOTIENT-FIX(DIVIDEND/DIVISOR) 

420 REMAINDER»DIVIDEND-DIVISOR*QUOTIENT 

430 REM XI-ONGOING COUNT OF X’, Y1-ONGOING COUNT OF Y*. YOU CAN KEEP TRACK OF 
ALL ONGOING COUNTS BY ONLY USING THE PREVIOUS 2 VALUES FOR X' AND Y\ SO 
WE ONLY NEED XI, X2, X3. AND Y1, Y2, Y3. 

440 X1 = 1:Y1—QUOTIENT 

450 REM IF EITHER A OR B IS AN EVEN MULTIPLE OF THE OTHER, THEN EITHER X’ OR 
Y’WILL EQUAL 1 WHILE THE OTHER EQUALS 0. 

460 IF REMAINDER-0 THEN X2-0:Y2-1:GOTO 620 
470 DIVIDEND-DIVISOR:DIVISOR-REMAINDER 
480 QUOTIENT-FIX(DIVIDEND/DIVISOR) 

490 REMAINDER-DIVIDEND-DIVISOR*QUOTIENT 
500 X2—QUOTIENT*X1:Y2-1-QUOTIENT*Y1 

510 REM IF A GCD IS FOUND ON THE SECOND ITERATION OF THE EUCLIDEAN ALGORITHM, 
THEN X'=X1, Y'-Y1. IN ALL SUBSEQUENT CASES. X’-X2, Y’-Y2. 

520 IF REMAINDER-0 THEN X2-X1:Y2-Y1:GOTO 620 

530 REM THE FIRST TWO ITERATIONS ARE THE ONLY ONES THAT DO NOT FOLLOW THE 
PATTERN: X(N)=X(N-2)-QUOTIENT*X(N-1), Y(N)-Y(N-2)-QU0TIENT*Y(N-1). 

540 WHILE REMAINDERO0 

550 DIVIDEND-DIVISOR:DIVISOR-REMAINDER 

560 QUOTIENT-FIX(DIVIDEND/DIVISOR) 

570 REMAINDER-DIVIDEND-DIVISOR*QUOTIENT 

580 IF REMAINDER-0 THEN 610 

590 X3-X1-QUOTIENT*X2:Y3-Y1-QUOTIENT*Y2 

600 X1-X2:X2-X3:Y1-Y2:Y2-Y3 

610 WEND 

620 REM CALCULATE BASIC SOLUTION FOR AX + BY = C FROM GCD RESULTS. WHICH HAVE 
PROVIDED AX’ + BY 1 = D BASIC SOLUTION. 

630 D=DIVISOR:E=C/D 

640 IF C/D<>INT(C/D) THEN PRINT "NO INTEGER SOLUTIONS.":GOTO 760 
650 IF SWAP.XY$-"YES" THEN SWAP X2.Y2 

660 PRINT "The boslc solution to the Dlophontine equation," 

670 PRINT EQUATION$;" is:" 

680 PRINT "X - ";X2*E:PRINT "Y - ";Y2*E 

690 PRINT "The GCD of ";A;" and ";B;" is:";ABS(D) 

700 PRINT "The parametric equations for all integer answers is:" 

710 PRINT "X - ";X2*E;:IF B/D>0 THEN PRINT " +"; 

720 PRINT B/D;"N, and" 

730 PRINT "Y »" ;Y2*E; : IF A/D<0 THEN PRINT " +"; ELSE PRINT " -"; 

740 PRINT ABS(A/D);"N" 

750 PRINT "for all integer values N." 

760 END 
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runkut.doc 
TEXT 

"The Runge-Kutta Methods # " Benku Thomas. 
ApriI, page 191. 


1. RUNKUT - AN INITIAL VALUE ORDINARY DIFFERENTIAL EQUATION 
SOLVER. 


1.1. INTRODUCTION 

RUNKUT Is a subroutine that contains three Runge-Kutta initial 
value ordinary differential equation (IVP ODE) solvers They are: 

A fourth order Fehlberg method. 

- A fifth order Verner method. 

An seventh order Verner method. 

RUNKUT solves coupled IV ODE’s of the form: 

Y* = F(x, Y) 

There is no limit to the number of coupled equations in a system 
to be solved other than the amount of memory available. The 
differential equations are defined in a user-supplied 
subroutine—more about that later. The subroutine is called 
using the following FORTRAN call statement: 

CALL RUNKUT(XA,Y,XB,NEQN,TOLA,TOLR.HSTART,WORK, 
k IMETH,IERROR.ICOM,FUNC) 

and must be called from a main "calling" program. 


1.2. VARIABLES PASSED TO RUNKUT. 

The variables passed are explained below and are listed in the 
order in which they appear in the call statement. The 
superscripted numbers refer to notes appearing at the end of this 
section. 

XA (Real-Input) 

XA is the starting point of the interval over which 
integration of the ODE’s is to be per formed.(1) 

Y (Real array of size NEQN - Input/Output) 

On entry, Y must contain the initial values of the 
Y-variables—that is Y must contain the solutions at the 
point XA. On exit from RUNKUT, Y wiI I contain the solutions 
at the end of the specified interval—that is at XB.(2) 

XB (Real-Input) 

XB specifies the end of the interval over which integration 
Is to be performed—the point at which solutions to the 
differential equations are desired.(1,2) 

NEQN (Integer-Input) 

NEQN specifies the number of coupled differential equations 
In the system to be solved. 

TOLA (Real-Input) 

TOLA Is the absolute error tolerance required on the 
solution.(3) 


(continued) 
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TOLR (Real-Input) 

TOLR Is the relative error tolerance required on the 
solution.(3) 

HSTART (Rea 1-Input/Output) 

On the very first call to RUNKUT In a caI I Ing‘sequence, 

HSTART must contain a non-zero value as an Initial estimate 
for the step-sIze.(1) The actual value used Is relatively 
unimportant as the program will optimize step-sizes to keep 
the tolerances within specified limits and keep the number of 
function evaluations to a minimum. It is left to the user’s 
discretion to choose a value that will not require excessive 
readjustment by the program. On exit from RUNKUT, this 
variable will contain the last step size used by the program. 
It is recommended that for subsequent calls to RUNKUT, the 
step size returned by the program be used as the value for 
HSTART to solve the equations over the Immediately following 
interval. 

WORK (Real array of minimum size NEQN*17 - Input) 

This is a work area made available to RUNKUT by the calling 
program. 

IMETH (Integer-Input) 

Indicates to the solver, the order of the method to be used. 
IMETH can take on the following values: 

1. - Fourth order Fehlberg method 

2. - fifth order Verner method 

3. - seventh order Verner method 

While solving a given set of differential equations it is 
possible to change the order of the method over sucessive 
intervals simply by setting IMETH to the desired value and 
resetting IC0M(1) to 0 on each subsequent call to RUNKUT in 
which a change of order is required.(4) 

IERROR (Integer-Output) 

IERROR is an error status indicator returned by RUNKUT after 
each call. It can have one of the following values: 

0 - no error. 

1 - the sum of TOLA and TOLR Is less than 100 times machine 

epsilon. This can be caused by setting both TOLA and TOLR 
to 0, or by specifying values that are too small for the 
program to handle sucessfully. In this case TOLR is set 
to a default value. 

2 - the problem is too stiff for the method to handle, or 

there is a discontinuity in the function. It is 
impossible to proceed in either case.(2) 

3 - both conditions 1 and 2 above have occured. 

IERROR is set to 0 on every entry to RUNKUT. 

ICOM (Integer array of size 4) 

ICOM is a communications vector. Each array element is used 
to pass a specific item of information (as defined below) to 
and from the subroutine. 

ICOM(1) (Input) 

ICOMM^ must be set to 0 on the first call to RUNKUT. 

IC0M(1) is internally set to a non-zero value by the program 
after the first call. For subsequent calls to RUNKUT with the 
same set of equations, IC0M(1) must be left at this non-zero 
value. It is possible to change the order of the method used 
(see also IMETH) over sucessive intervals. In this case 
IC0M(1) must be reset to 0 each time the order of the method 
is changed.(4) 

IC0M(2) (Input) 

A flag that indicates to the program whether to perform 
checks on the specified values of TOLA and TOLR. 

0 - no checking of the error tolerances. 

1 - program checks if the sum of TOLA and TOLR is at least 
100 times machine epsilon. If not, TOLR is set to a 
default value and the error indicator IERROR is set to 1. 
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If IC0M(2) is set to 0, the program assumes that it will be 
receiving non-zero values of at least one of TOLA or TOLR. 
Failure to check this before entry to RUNKUT could result in 
fatal program errors. Also, as will be shown in an example, 
decreasing the error tolerances does not always result in 
improved solution accuracy. 

IC0M(3) (Input) 

A flag that indicates to the program whether to use the 
default values of mimimum and maximum step size set by the 
subroutine.(5) 

0 - default values of the maximum and minimum step size are 
used. 

1 - allows the user to set values for the maximum and minimum 
permissible step size. These values are set by including 
the following FORTRAN common block statement in the main 
"caI Iing" program: 

COMMON /CONS/HMIN,HMAX 
IC0M(4) (Output) 

Status flag that indicates the presence of round-off 
error in the solution. 

0 - No round-off error. 

1 - Severe round-off error possible in answer. 

IC0M(4) is reset to 0 on entry to RUNKUT. 

FUNC (Function name) 

FUNC is replaced by the name of the subroutine that is 
part of the main user routine In which the differential 
equations are specified (See section on user supplied 
routines). The subroutine name must be declared external 
by the following FORTRAN statement: 

EXTERNAL [SUBROUTINE NAME]. 


1.2.1. NOTES 

1. XA could be greater than XB. In other words it is 
possible to use RUNKUT to solve the differential 
equations in a negative X-direction given initial values 
at XA. In that case the step-size will also be negative. 
HSTART could be specified as a negative value, but that 
is not essential as the program internally adjusts the 
algebraic sign of the step-size. 

2. If a discontinuity or extreme stiffness is encountered, 
RUNKUT will return in XB, the value of X closest to the 
point of discontinuity or stiffness, at which the 
solutions are still within the specified error bounds. 

The array Y wiI I then contain solutions at this value of 
X. 

3. If the sum of TOLA and TOLR is less than 100 times 
machine epsilon (for example if neither were defined in 
the main program), TOLR is set to a default value of 
10(6) times machine epsilon. TOLA is not set to any 
default value. The program uses a combination of TOLA and 
TOLR to determine the accuracies of the solutions, and 
specifying TOLR to a certain value almost always gives 
better results than specifying TOLA to the same value. 

4. Changing the order of the method on every subsequent call 
to RUNKUT with a given system of equations can lead to 
excessive computaion times since a large number of 
constants are re-evaluated each time the order is 
changed. 

5. The default values used by the subroutine are 10(-8) for 
HMIN, and for HMAX as follows: 

0.5 - if the fourth order method is used. 

1.0 - If the fifth order method is used. 

2.0 - If the seventh order method is used. 


( continued) 
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However, If ony of these values are larger than the 
absolute value of the Interval width, HMAX Is set to the 
Interval width. It is sometimes necessary to specify HMAX 
to a small value to keep the step sizes to relatively 
small values that keep the runge-kutta methods within 
regions of stability. The subroutine detects the onset of 
problem "stiffness" or the occurence of a discontinuity 
In the function by checking if the step size is smaller 
than HMIN. If the equations are being solved in the 
negative X-direction, HMIN and HMAX are the smallest and 
largest permissible step sizes in the negative 
X-direction respectively. In other words, HMIN and HMAX 
always define absolute constraints on the step size. 

6. Machine epsilon on the IBM PC is very much a function of 
the compiler used (even with an 8087 math coprocessor 
installed). For example Microsoft's Fortran-77 compiler 
(with 8087 support) generates an epsilon of about 
10(-16), whereas IBM/Ryan-McFarI and's Professional 
Fortran-77 generates an epsilon of about 10(-20) 


1.3. THE USER-SUPPLIED ROUTINES 
Two routines must be supplied: 

1. A main "calling" program that calls RUNKUT. It must also 
define the Initial values of Y at XA, set TOLA and TOLR, 
set IC0M(1) to 0 on the first call to RUNKUT. define the 
number of equations in the sytstem to be solved, 
dimension a WORK array for RUNKUT, and check for the 
error status as passed back from RUNKUT through IERROR. 
See the examples at the end of this section. 


2. A subroutine containing the system of differential 

equations. The subroutine name must be declared EXTERNAL 
in the main calling program and its name passed to RUNKUT 
through the parameter FUNC-see above. The subroutine is 
defined using the foilwing FORTRAN statement: 

SUBROUTINE [FUNC] (X.Y.YPRIME.NEQN) 

where the parameters have the following definitions: 

X (Real) 

Contains the current value of X as set in RUNKUT. Do 
not alter this value within [func] 

Y (Real - array of size NEQN) 

Contains the current solutions at X. Do not alter in 
[func]. 

YPRIME (Real - array of size NEQN) 

YPRIME is set in the subroutine to the differentials 
dy/dx as follows: 

YPRIME(1) - F/1/(X,Y(1),...,Y(NEQN)) 

YPRIME(NEQN)*F/NEQN/(X,Y(1).Y(NEQN)) 

where F/i/ is the i'th differential function. 

1. RUNKUT - AN INITIAL VALUE ORDINARY DIFFERENTIAL 
EQUATION SOLVER. 


1.1. INTRODUCTION 

RUNKUT is a subroutine that contains three 
Runge-Kutta initial value ordinary differential 

equation (IVP ODE) solvers They are: 
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A fourth order Fehlberg method. 

A fifth order Verner method. - An seventh order 

Verner method. 

RUNKUT solves coupled IV ODE’s of the form: 

V = F(x, Y) 

There is no limit to the number of coupled 
equations in a system to be solved other than the 

amount of memory available. The differential 

equations are defined in a user-supplied 

subroutine—more about that later. The subroutine is called 
using the following FORTRAN call statement: 

CALL 

RUNKUT(XA,Y.XB,NEQN,TOLA,TOLR,HSTART,WORK, & 

IMETH,IERROR,ICOM.FUNC) 

and must be called from a main "calling" program. 

1.2. VARIABLES PASSED TO RUNKUT. 

The variables passed are explained below and are 
listed in the order in which they appear in the 

call statement. The superscripted numbers refer to 

notes appearing at the end of this section. 

XA (Real-Input) XA Is the starting 

point of the interval over which integration of 

the ODE’s is to be per formed.(1) 

Y (Real array of size NEQN - Input/Output) 

On entry, Y must contain the initial values of the 
Y-variables—that is Y must contain the solutions at the 
point XA. On exit from RUNKUT. Y wlI I contain the solutions 
at the end of the specified interval—that is at XB.(2) 

XB (Real-Input) XB specifies the end 

of the interval over which integration is to be 

performed—the point at which solutions to the 
differential equations are desired.(1,2) 

NEQN (Integer-Input) NEQN specifies 

the number of coupled differential equations in 

the system to be solved. 

TOLA (Real-Input) TOLA is the 

absolute error tolerance required on the 
solution.(3) 

TOLR (Real-Input) TOLR is the 

relative error tolerance required on the 
solution.(3) 

HSTART (Real-Input/Output) On the 

very first call to RUNKUT In a calling sequence, 

HSTART must contain a non-zero value as an initial estimate 
for the step-size.(1) The actual value used is relatively 
unimportant as the program will optimize step-sizes to keep 
the tolerances within specified limits and keep the number of 
function evaluations to a minimum. It is left to the user’s 
discretion to choose a value that will not require excessive 
readjustment by the program. On exit from RUNKUT, this 
variable will contain the last step size used by the program. 
It Is recommended that for subsequent calls to RUNKUT, the 
step size returned by the program be used as the value for 
HSTART to solve the equations over the immediately following 
intervaI. 


WORK (Real array of minimum size NEQN*17 - Input) 
This Is a work area made available to RUNKUT by the calling 
program. 


IMETH (Integer-Input) Indicates to 

the solver, the order of the method to be used. 

IMETH can take on the following values: (continued) 
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1. - Fourth order Fehlberg method 

— fifth order Verner method 3. ■ seventh 

order Verner method 

While solving a given set of differential 
equations It is possible to change the order of 

the method over sucessive intervals simply by 

setting IMETH to the desired value and 

resetting IC0M(1) to 0 on each subsequent call to RUNKUT in 
which a change of order is required.(4) 

IERROR (Integer-Output) IERROR is an 

error status indicator returned by RUNKUT after 
each call. It can have one of the following values: 

_ 4 0 " no error. 1 - the sum of 

TOLA and TOLR is less than 100 times machine 
epsilon. This can be caused by setting both TOLA and TOLR 
to 0, or by specifying values that are too small for the 
program to handle sucessfully. In this case TOLR is set 

to a default value. 2 - the 

problem is too stiff for the method to handle, or 
there is a discontinuity in the function. It is 
impossible to proceed in either case.(2) 3 - 

both conditions 1 and 2 above have occured. 

IERROR is set to 0 on every entry to RUNKUT. 

ICOM (Integer array of size 4) ICOM 

is a communications vector. Each array element is used 
to pass a specific Item of Information (as defined below) to 
and from the subroutine. 

ICOM(1) (Input) ICOM(1) must be set 

to 0 on the first call to RUNKUT. IC0M(1) is 

internally set to a non—zero value by the program 
after the first call. For subsequent calls to RUNKUT with the 
same set of equations, IC0M(1) must be left at this non-zero 
value. It is possible to change the order of the method used 
(see also IMETH) over sucessive intervals. In this case 
ICOM(1) must be reset to 0 eoch time the order of the method 
Is changed.(4) 

IC0M(2) (Input) A flag that indicates 

to the program whether to perform checks on the 

specified values of TOLA and TOLR. 

0 - no checking of the error tolerances. 

1 - program checks if the sum of TOLA and TOLR is at least 
100 times machine epsilon. If not, TOLR is set to a 
default value and the error indicator IERROR is set to 1. 

If IC0M(2) is set to 0, the program assumes 
that it will be receiving non-zero values of at 

least one of TOLA or TOLR. Failure to check 

this before entry to RUNKUT could result in 
fatal program errors. Also, as will be shown in an example, 
decreasing the error tolerances does not always result in 
improved solution accuracy. 

IC0M(3) (Input) A flag that indicates 

to the program whether to use the default 

values of mimimum and maximum step size set by the 
subroutIne.(5) 


0 - default values of the maximum and minimum 
step size are used. 1 - 

allows the user to set values for the maximum and minimum 
permissible step size. These values are set by including 
the following FORTRAN common block statement in the main 
"calIIng" program: 
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COMMON /CONS/HMIN,HMAX 

IC0M(4) (Output) Status flag 

that Indicates the presence of round-off 

error in the solution. 0 - No round-off 

error. 1 - Severe round-off error possible 

in answer. 


IC0M(4) is reset to 0 on entry to RUNKUT. 

FUNC (Function name) FUNC is 

replaced by the name of the subroutine that is 
part of the main user routine in which the differential 
equations are specified (See section on user supplied 
routines). The subroutine name must be declared external 
by the following FORTRAN statement: 

EXTERNAL [SUBROUTINE NAME]. 


1.2.1. NOTES 

1. XA could be greater than XB. In other words 

It is possible to use RUNKUT to solve the 

differential equations in a negative 

X-direction given Initial values at XA. In 

that case the step-size will also be negative. 

HSTART could be specified as a negative value, but that 
is not essential as the program internally adjusts the 
algebraic sign of the step-size. 

2. If a discontinuity or extreme stiffness is 

encountered, RUNKUT will return in XB, the 

value of X closest to the point of 

discontinuity or stiffness, at which the 

solutions are still within the specified error bounds. 

The array Y wiI I then contain solutions at this value of 
X. 


3. If the sum of TOLA and TOLR is less than 

100 times machine epsilon (for example if 

neither were defined in the main program), 

TOLR is set to a default value of 10(6) 

times machine epsilon. TOLA is not set to any 

default value. The program uses a combination of TOLA and 
TOLR to determine the accuracies of the solutions, and 
specifying TOLR to a certain value almost always gives 
better results than specifying TOLA to the same value. 

4. Changing the order of the method on every 

subsequent call to RUNKUT with a given 

system of equations can lead to excessive 

computaion times since a large number of 

constants are re-evaluated each time the order is 
changed. 

5. The default values used by the subroutine 

are 10(-8) for HMIN, and for HMAX as 

foI lows: 

0.5 - If the fourth order method is used. 

1.0 - if the fifth order method is used. 

2.0 - if the seventh order method is used. 

However, if any of these values are larger 
than the absolute value of the interval 

width, HMAX Is set to the interval width. 

It Is sometimes necessary to specify HMAX 
to a small value to keep the step sizes to relatively 
small values that keep the runge-kutta methods within 
regions of stability. The subroutine detects the onset of 
problem “stiffness" or the occurence of a discontinuity 
in the function by checking if the step size is smaller 
than HMIN. If the equations are being solved in the 
negative X-direction, HMIN and HMAX are the smallest and 
largest permissible step sizes in the negative 
X-dlrection respectively. In other words, HMIN and HMAX 

always define absolute constraints on the step size. ( continued ) 
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6. Machine epsilon on the IBM PC is very much 
a function of the compiler used (even with 

an 8087 math coprocessor installed). For 

example Microsoft's Fortran-77 compiler 
(with 8087 support) generates an epsilon of about 
10(-16), whereas IBM/Ryan-McFarI and *s Professional 
Fortran-77 generates an epsilon of about 10(-20) 


1.3. THE USER-SUPPLIED ROUTINES 

Two routines must be supplied: 

1. A main "calling" program that calls RUNKUT. 
It must also define the initial values of Y 

at XA, set TOLA and TOLR, set IC0M(1) to 0 

on the first call to RUNKUT, define the 
number of equations In the sytstem to be solved, 

dimension a WORK array for RUNKUT, and check for the 
error status as passed back from RUNKUT through IERROR. 

See the examples at the end of this section. 


2. A subroutine containing the system of 
differential equations. The subroutine 

name must be declared EXTERNAL In the main 

calling program and its name passed to RUNKUT 
through the parameter FUNC-see above. The subroutine is 
defined using the foilwing FORTRAN statement: 

SUBROUTINE [FUNC] (X.Y,YPRIME.NEQN) 

where the parameters have the following 

definitions: 


X (Real) Contains the 

current value of X as set in RUNKUT. Do 
not alter this value within [func] 

Y (Real - array of size NEQN) 

Contains the current solutions at X. Do not alter in 
[func]. 


YPRIME (Real - array of size NEQN) 
YPRIME is set in the subroutine to the differentials 
dy/dx as foilows: 


YPRIME(I) = F/1/(X,Y(1),....Y(NEQN)) 

YPRIME(NEQN)=F/NEQN/(X,Y(1).Y(NEQN)) 

where F/i/ is the i'th differential 

function. 

The following table should be printed out in 132-column format. 


TABLE 2 - The numerical solution of the equations in example 3. 
(TOLR « 1.E-10, TOLA - 0.0) 


RKF-4 RKV-5 RKV-7 


x y(i) y(2) 


y(i) y(2) y(i) 


y(2) 


.0 .750000000 .000000000 
.5 .619768033 .477791373 
1.0 .294417538 .812178519 

1.5- .105176381 .958038093 
2.0-.490299792 .939874997 

2.5- .813942831 .799590803 
3.0-1.054031516.575706079 

3.5- 1.200735041.300160709 
4.0-1.250000000.000000000 


.750000000 

.619768033 

.294417538 

-.105176381 

-.490299792 

-.813942831 

-1.054031516 

-1.200735041 

-1.250000000 


.000000000 .750000000 
.477791373 .619768033 
.812178519 .294417538 
.958038093-.105176381 
.939874997 -.490299792 
.799590803 -.813942831 
.575706079 -1.054031516 
.300160709 -1.200735041 
.000000000 -1.250000000 


.000000000 

.477791373 

.812178519 

.958038093 

.939874997 

.799590803 

.575706079 

.300160709 

.000000000 
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4.5- 
5.0- 

5.5- 
6 . 0 - 

6.5- 
7.0 

7.5 
8.0 

8.5 
9.0 

9.5- 
10.0- 
10.5- 
11.0 
11.5 
12.0 


1.200735041-, 

1.054031516- 

.813942831 - 

.490299792 - 

.105176381 - 

.294417538 - 

.619768033 - 

.750000000 

.619768032 

.294417538 

.105176382 

.490299793 

.813942832 

-1.054031516 

-1.200735042 

-1.250000000 


300160709 -1 
575706079 -1 
799590803 -. 
939874997 -. 
,958038093 -. 
,812178519 . 

477791373 . 

,000000000 . 
.477791374 . 

.812178520 . 

.958038093 -. 
.939874996 -. 
.799590803 -. 
.575706078 
.300160708 
-.000000001 


.200735041 -. 
.054031516 -. 
813942831 -. 

490299792 -, 

105176381 - 

294417538 - 

619768033 - 

750000000 
619768033 
294417538 
105176381 
490299792 
813942831 
-1.054031516 
-1.200735041 
-1.250000000 


300160709 - 
575706079 - 
799590803 - 
939874997 - 
958038093 - 
812178519 
477791373 
000000000 
,477791373 
.812178519 
.958038093 - 
.939874997 ■ 
.799590803 - 
.575706079 
.300160709 
.000000000 


1.200735041 
1.054031516 
.813942831 
.490299792 
.105176381 
.294417538 
.619768033 
.750000000 
.619768033 
.294417539 
•.105176381 
-.490299792 
-.813942831 
-1.054031516 
-1.200735041 
-1.250000000 


-.300160708 

-.575706078 

-.799590803 

-.939874997 

-.958038093 

-.812178519 

-.477791373 

.000000000 

.477791373 

.812178519 

.958038093 

.939874997 

.799590804 

.575706079 

.300160709 

.000000001 


Re 1 ative 

error 1.220E-010 
at x=12 

5.665E-010 6.948E-012 1.184E-010 

1.919E-010 8.529E-010 

Total function 
eva1uations 

2928 2640 

1872 


The following table should be printed out in 132-column format. 

TABLE 3 - Comparison of code accuracy and efficiency for different 

expressions for the parameter POWER in the step size adjuster. 



RKF- 

-4 

RKV- 

*5 

RKV-7 


examp 1e: 

i 

(ot x-1) 

2 

(at x-12) 

y(D 

i 

(ot x-1) 

2 

(at x-12) 

i 

(at x-1) 

2 

(ot x-12) 

with POWER 
= O/p+i) 

[.567E-08] 
(3216) 

[1.22E-10] 

(2928) 

[ . 138E-08] 
(2008) 

[6.95E-12] 

(2640) 

[.276E-08] 
(1053) 

[1.92E-10] 
(1872) 

with POWER 
* O/p) 

[.713E-08] 
(3072) 

[1.54E-10] 

(2844) 

[.165E-08] 
(1968) 

[8.68E-12] 

(2472) 

[.316E-08] 

(1053) 

[1.92E-10] 
(1703) 


- The figures in square brackets [] are absolute values of the relative global errors 

- The figures in round brackets () are total number of function evaluations taken to 
reach specified x value from the starting point. 

(TOLA ■ 0, TOLR * 1.E-09 for example 1 and 1.E—10 for example 2) 


predict.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
ApriI, page 191. 


$NOFLOATCALLS 
$NODEBUG 
$STORAGE:2 

subroutine rkp(x,ys,h,neqn,Imeth,kt,est,yoId.ynew.w,func) 


implicit double precision (a-h,k,p-z) 
external func 

dimension w(13,neqn),kt(neqn),ys(neqn),est(neqn) 
dimension a I(12),b(12,12),yoId(neqn).ynew(neqn) 

(continued) 
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common /coeffs/al,6,01,03,04,05,06,07,08,09,010,011, 
& 0l2,a13,er1,er3,er4,er5,er6,er7,er8, 

& er9,er10,er11,er12,er13,Inum 

xs-x 

do 5 i*1,neqn 
ys(l)-yold(!) 
contInue 

call func(xs,ys,kt,neqn) 
do 7 1*1,neqn 
w(1.l)-kt(I) 
contInue 


10 

15 


17 

20 


do 20 j*2,lnum 
JI-j-1 

xs*x+h*aI(J1) 
do 15 i*1,neqn 
ksum=0.d0 
do 10 m*1,J1 

ksum*ksum+b(m,j1)*w(m,I) 
continue 

ys(I)*yoId(I)+h*ksum 
contInue 

call func(xs,ys,kt,neqn) 
do 17 i*1,neqn 

w(JJ)-kt(i) 

continue 
contInue 


c**** evaluate YNEW[I] and the error estimates EST[i] 

If(lmeth.EQ.I) then 
do 30 1*1,neqn 

ynew(i)*yoId(I)+h*(a1*w(1,I)+a3*w(3,l)+a4*w(4,i) 

& +a5*w(5,i)+a6*w(6,I)) 

est(I)*h*(er1*w(1,1)+er3*w(3,i)+er4*w(4,I)+er5*w(5,I) 

& +er6*w(6,i)) 

30 continue 

end I f 

If(Imeth.EQ.2) then 
do 40 1*1,neqn 

ynew(I)*yoId(I)+h*(a1*w(1,i)+a3*w(3,I)+a4*w(4,i) 

& +a5*w(5,I)+a7*w(7,i) 

& +a8*w(8,I)) 

est(I)*h*(er1*w(1,I)+er3*w(3,i)+er4*w(4,I)+er5*w(5,i) 

& +er6*w(6,I)+er7*w(7,i)+er8*w(8,i)) 

40 continue 

end if 

if(Imeth.EQ.3) then 
do 50 i=1,neqn 

ynew(i)*yoId(i)+h*(a1*w(1,i)+a6*w(6,i)+a7*w(7,i) 

& +a8*w(8,i)+a9*w(9,i) 

& +a12*w(12,i)+a13*w(13,i)) 

est(i )=h*(er1*wM , i ) 

& +er6*w(6,i)+er7*w(7,i)+er8*w(8,i)+er9*w(9,i) 

& +er10*wf10,i}+er11*w(11,i)+er12*w(12,i) 

& +er13*w(13,i;) 

50 continue 

end if 


return 

end 
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runkut.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
Apr i I, page 191. 


$NOFLOATCALLS 
$NODEBUG 
$STORAGE:2 

c***************************************************************************** 
c NOTE: Some of the variables are not the same as in the article 

c For example hadj = v, est=e(i+1), hfact=s, hlim = vlim. 

c***************************************************************************** 

c 

c 

subroutine runkut(xa,ya,xb,neqn,tola,tolr,hstart,w, 
k imeth,ierror,icom,func) 

c 

c**** This is simply a front-end subroutine to split up the work 
c**** array specified by the user into smalller arrays 
c 

implicit double precision (a-h,k,o-z) 
external func 
dimension icom(4),w(*) 
common /epsil/eps 

cal I solver(xa,ya,xb,neqn,tola,tolr,hstart,ierror,imeth, 
k icom(1),icom(2),icom(3),icom(4),w(1),w(1+neqn), 

k w(1+neqn*2),w(1+neqn*3),w(1+neqn*4),func) 

return 
end 

c***************************************************************************** 

c 

c 

subroutine solver(xa,ya,xb,neqn,tola,tolr,hstart,ierror,Imeth, 
k 1st,ichk,idef,iround,kt,est,yoId,ynew,w,func) 

implicit double precision (a-h,k,o-z) 
logical hflag 
external func 

dimension ya(neqn),w(13,neqn),kt(neqn) 
dimension est(neqn),yoId(neqn),ynew(neqn) 
common /cons/hmin,hmaxI,hfact,hIim,power 
common /epsil/eps 

c * * * * If TOLA is set to zero, then a relative error test 

c**** If TOLR is set to zero, then an absolute error test 

c**** If neither are set to zero, then a mixed error test 

c***» If this is the first call to RUNKUT calculate the machine 

c**** epsilon and work out the constants depending on method used, 
c**** To ensure that the results will always be "safe", the value 
c**** EPS used by RUNKUT is actually 20 times the machine epsilon. 

if(ist.EQ.0) then 
call caleps 

call const(ist,imeth,idef) 
eps=eps*20.d0 
end i f 

c**** Check If the sum of TOLA and TOLR is greater than 10*EPS 
c**** If not, set TOLR to one million times EPS. 

ierror=0 

if(ichk.GT.0)then 

if(tola+tolr.LT.10.d0*eps)then 
ierror«1 
to Ir*1.d06*eps 
end if 
end I f 
1round«0 

isig«dint((xb-xa)/dabs(xb-xa)) 

ho Id-hstart 

x*xa 


( continued) 
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10 

do 10 1*1,neqn 
yold(i)-yo(i) 
continue 

c#*** 

c**** 

c**** 

Set HMAX to the maximum value HMAXL set in CONST unless this 
is greater than the interval width, in which case HMAX is 
equal to the interval width. 

hmax-dminl(hmax1,dabs(xa-xb)) 

c**** 

c * * * * 

call the runge-kutta solver using the current step size 
to predict y(n+1) 

15 

cal 1 rkp(x,ya,ho1d,neqn,imeth,kt,est,yo1d,ynew,w,func) 

c**** 

c**** 

calculate step size adjustment factor HADJ 

then calculate HNEW using the smallest value of HADJ 

20 

hadj*9999.d0 
do 20 1*1,neqn 

absest*dabs(est(i)) 
if(absest.EQ.0)then 
had j1=h1im 
e 1 se 

if(yold(i).EQ.0)then 

hadjl*((tola+tolr*tolr)/absest)**power 
e 1 se 

hadjl*((tola+tolr*dabs(yold(i)))/absest)**power 
end i f 
end i f 

if(hadj1.LT.hadj) hadj-hadjl 
contInue 

c**** 

c**** 

c** + * 

c**** 

adjust the step size to HNEW using the calculated value of HADJ 
unless HADJ is greater than HLIM, in which case use HUM 

If HNEW is larger than HMAX, choose HMAX as the new step size 

If HNEW is less than HOLD/10, keep HNEW as HOLD/10 to avoid 
excessively large swings in the step size 

& 

holdl-dabs(hold) 
hnew * dmaxl(ho 1 di/10., 

dminl(hfact*ho1d1*(dmin1(hadj,hlim)),hmax)) 

c**** 

c**** 

c**** 

c**#* 

c**** 

c**** 

C**** 

C **** 

c**** 

Check if HOLD is large enough compared to EPS to avoid 
severe round-off errors. If HNEW is less than HMIN, the 
problem has got too stiff or is discontinous-exit saving 
the last points calculated. If the last step was sucessful 
let YOLD*YNEW and calculate YNEW using new step size. If it 
was unsuccessful, recalculate YNEW using reduced step size. 

If the HOLD was a reduced step size, then restrict HNEW to HOLD 
If XB will be reached or exceeded, exit after calculating 

Y at XB. 

30 

if(dabs(x).GT.0) then 

if((hnew/(dabs(x)*18.d0)).LE.eps) iround*1 
end i f 

if(hnew.GE.hmin) then 
hnew=isig*hnew 

If(hadj.GE.1.d0) then 

if(isig*(x+ho1d-xb).LT.0.d0) then 
x*x+ho1d 

if(.not.hf1ag) hnew*hold 
hf1ag*.true. 
do 30 i*1,neqn 
yold(i)*ynew(l) 
continue 
ho 1d=hnew 
goto 15 
e 1 se 

hstart*hnew 

50 

ho 1d=xb-x 

cal 1 rkp(x,ya,hold,neqn,imeth,kt,est,yo1d,ynew,w,func) 
do 50 i*1,neqn 
ya( i)=ynew(i) 
continue 
end i f 
e 1 se 
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hfIag*.false, 
ho Id=hnew 
goto 15 
end i f 
e I se 

hnew=isig*hnew 
ierror=ierror+2 
xb«x 

do 60 i»1,neqn 
y°( •)*yold( I) 
60 continue 

end I f 
return 
end 


ordit.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
Apr I I, page 191. 


$NOFLOATCALLS 
SNODEBUG 
$STORAGE:2 

c**** User’s calling program 

c**** NEQN*4 so dimension of work array = 4*17 = 68 

implicit double precision (a-h.o-z) 
dimension y(4),work(68),icom(4) 
external orbit 
common alfasq 

open(2,fiIe=' *.status-’new’) 
icom(1)*0 

wr ite(*,*) •imeth«,tola»,tolr»* 
read(*,*) imeth,to I a,to Ir 
ecc=0.25d0 

a If a*3.141592653589d0/4.d0 

a I fasq=aIfa*aI fa 

neqn«4 

hstart=0.01d0 
y(1)«1.d0-ecc 
y(2)-0.d0 
y(3)»0.d0 

y(4)*aIfa*dsqrt((1.d0+ecc)/(1.d0-ecc)) 
x0-0.d0 
xb»0.d0 
icomf2J«0 
icom(3)*0 
do 20 j-1.24 
xa«xb 

xb=0.5d0*dbIe(j)+x0 
wrlte(2,100)xa,y(1),y(2) 

cal I runkut(xa,y,xb,neqn,tola,to Ir,hstart,work, 

& imeth,ierror,icom,orbit) 

if(ierror.GT.1) then 

write(2,100)xb,y(1),y(2) 

writef2,*) • ERROR-ProbIem too stiff or is discontinous’ 
cIose(2) 
stop 
end i f 

20 contInue 

if(icom(4).GT.0)write(2,*) " Severe round-off error possible 
stop 

100 format(F5.1,3F15.9) 

end 

C *********************************************^********** , * c ********** , * t 
c**** User supplied subroutine that contains the system of 
c**** differential equations to be solved. 

c**** Notice that in this routine it is necessary to have an array 
c**** yprime(neqn) 
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subroutine orbit (x.y.yprirne.neqn) 
implicit double precision (a-h,o-z) 
dimension y(neqn),yprime(neqn) 
common alfasq 

r-y(1)*y(1)+y(2)*y(2) 
r«r*dsqrt(r)/alfasq 
yprime(1)*y(3) 
yprime(2)*y(4) 
ypr imef32«-y(1 )/r 
ypr ime(4)—y(2;/r 
return 
end 


react.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
Apr I I, page 191. 


$NOFLOATCALLS 
$NODEBUG 
$STORAGE:2 


Implicit double precision (a-h,p-z) 
dimension y(2),work(34),icom(4) 
external freact 

common /reacts/ifeval,Da,deIta,beta,Hw,Tw 

open(2,file= * *,status* ’new’) 

Ifeva1=0 
Icomf1 
icom(2)*0 
lcom(3)*0 

write(*,*) ’Wall Temp.=, Reactant Inlet Temp=, htc-’ 
read(*,*) Tw.Tr.U 
Tw»Tw/Tr 
U-U/1000.0 

write(*,*) * imeth=, tola=, tolr»' 
read(*,*) imeth,to I a,to Ir 

c**** evaluate constants In the equations 
Da=2.d0*5.d0/3.d0 
beta=0.03d0*1,d04/1,2d0/1.d0/Tr 
delta=1,d3/8.3144d0/Tr 
Hw»2.d0*U*2.d0/0.1d0/1.2d0/1.d0/3.d0 

c**** 

hstart=0.01d0 
neqn*2 
x0=0.d0 
xb=0.d0 
y(1)*1.d0 
y(2)*1.d0 
conc=yf12*0.03 
temp=y(2)*Tr 

write(2,30)xa,y(1),y(2),hstart 
do 20 j-1,10 
xa*xb 

xb«0.1*dble(j)+x0 

cal I runkut(xa,y,xb,neqn,tola,to Ir,hstart.work, 

& imeth,ierror,icom,freact) 

conc*y(1)*0.03 
temp*y(2)*Tr 
if(ierror.GT.1)then 
writef2,30)xb,y(1),y(2),hstart 

write(2,*)’ ERROR-ProbIem too stiff or is discontinous• 
close(2) 
stop 
e I se 

write(2.30)xb,y(l),y(2),hstart 
end i f 
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20 continue 

i f ( icom(4).GT.0) write(2,*) * Severe round-off error possible* 
write(2,*) * Number of function evaluations * *,ifeval 
close (2) 
stop 

30 format(1x,f11.2.1x,d15.6,1x,f15.4,lx,d15.6) 

end 

c user supplied subroutine containing the system of first 

c order ordinary initial value differential equations 

subroutine freact(x,y,yprime,neqn) 

implicit double precision (a-h,p-z) 

dimension y(neqn),yprime(neqn) 

common /reacts/ifeval,Da,delta,beta,Hw,Tw 

yprime(1)* -Da*y(1)*dexp(deIta*(1.d0-1.d0/y(2))) 
yprime(2)» beta*Da*y(1)*dexp(deI ta*(1.d0-1.d0/y(2))) 

& -Hw*(y(2)-Tw) 

i feval = ifeva1 + 1 

return 

end 


rkconst.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
ApriI, page 191. 


$NOFLOATCALLS 
$NODEBUG 
$STORAGE:2 

C************************************************************************* 

subroutine const(ist,imeth,idef) 

c**** subroutine supplies constants used in the runge-kutta 
c**** method,in the format required by RKP. 

Implicit double precision (a-h,p) 
dimension al(12),b(12,12) 

common /coeffs/al,b,a1,a3,a4,a5,a6,a7,a8,a9,a10,a11, 

& a12,a13,er1,er3,er4,er5,er6,er7,er8, 

& er9,er10,er11,er12,er13,inum 

common /cons/hmin,hmaxI,hfact,hlim,power 

do 10 j-1,12 
do 5 1-1,12 
b(i,j)-0.d0 
5 continue 

a I (j)*0.d0 
10 continue 

if(imeth.EQ.I) then 

c**** Fourth order runge-kutta method specified by 

c**** Felberg, E., COMPUTING, 6(1970)p61-71 

c write(*,*) ’Fourth order Runge-Kutta-FehI berg method* 


al (0 

1-1.d0/4.d0 

o 1 < 

23 

l-3.d0/8.d0 

all 

3 

I-I2.d0/I3.d0 

a 1 < 

43 

1-1.d0 

al < 

5 

1-1.d0/2.d0 


b(1,1)«1.d0/4.d0 

b(1,2)»3.d0/32.d0 

b(2,2)-9.d0/32.d0 

b(1,3)-1932.d0/2197.d0 

b (2,3)—7200. d0/2197. d0 

b(3,3)-7296.d0/2197.d0 

b(1,4)«439.d0/216.d0 

b(2,4)*-8.d0 ( continued) 
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b(3,4)=3680.d0/513.d0 
b(4,4)«-845.d0/4104.d0 
b(1,5)—8.d0/27.d0 
b(2,5l=2.d0 

b (3,5)—3544. d0/2565. d0 
bU,51=1859.d0/4104.d0 
b(5,5)=-11.d0/40.d0 

er1«1,d0/360.d0 
er3=-384.d0/12825.d0 
e r 4—41743.d0/1429560.d0 
er5=1.d0/50.d0 
er6=2.d0/55.d0 

01-16.d0/135.d0 
o2=0.d0 

o3=6656.d0/12825.d0 
04=28561.d0/56430.d0 
o5=-9.d0/50.d0 
o6-2.d0/55.d0 

lnum-6 
i st=4 

i f ( idef.eq.0) hmoxl=0.5d0 
hiIm1=3.d0 
end I f 


c**»* 

c**** 

c 


If(imeth.EQ.2) then 

Fifth order runge-kutto method specified by 
Verner J.H., SIAM J. Numer. Anal. V15.(1978),p772.(tabIe 5) 
wrlte(*,*) ’Fifth order Runge-Kutta-Verner method' 
a I (11=1.d0/18.d0 

2) =1.d0/6.d0 

3) =2.d0/9.d0 

4) =2.d0/3.d0 
51=1,d0 

)=8.d0/9.d0 
1. d0 


al 
a I 
ol 
a I 
al 


6 


ol(7). 


bf1,11=1,d0/18.d0 
b(1.2)=-1.d0/12.d0 
bf2,2)»1.d0/4.d0 
b(1,3)=-2.d0/81.d0 
bf2,3)=4.d0/27.d0 
b(3.3)=8.d0/81.d0 
b(1,4)=40.d0/33.d0 
b(2,4)—4.d0/11.d0 
b(3,4)—56.d0/11.d0 
b(4,4)=54.d0/11.d0 
b(1,5)=-369.d0/73.d0 
b(2,5)=72.d0/73.d0 
b(3,5l=5380.d0/219.d0 
b(4.5)=-12285.d0/584.d0 
bf5,51=2695.d0/1752.d0 
b(1.6)=-8716.d0/891.d0 
bf2.61=656.d0/297.d0 
b(3,6)=39520.d0/891,d0 
b(4*6)=-416.d0/11,d0 
b(5.6)=52.d0/27.d0 
bf1,7)=3015.d0/256.d0 
b(2,7)=-9.d0/4.d0 
b(3.71—4219. d0/78.d0 
b(4,7)=5985.d0/128.d0 
b ( 5.7)=-539.d0/384.d0 
b(7,7)=693.d0/3328.d0 

e r1=33.d0/640.d0 
er3=-132.d0/325.d0 
er4=891.d0/2240.d0 
e r5=-33.d0/320.d0 
e r 6—73. d0/700. d0 
er7=891,d0/8320.d0 
er8=2.d0/35.d0 
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C**** 
C**** 

c 


a1=57.d0/640.d0 
a3—16.d0/65.d0 
a4=1377.d0/2240.d0 
a5-121.d0/320.d0 
07=891.d0/8320.d0 
o8=2.d0/35.d0 

inum=8 
i st=5 

if(idef.eq.0) hmaxl=1.0d0 
hiim1=4.d0 
end 1 f 

if(imeth.EQ.3) then 

Seventh order runge-kutto method specified by 

Verner J.H., SIAM J. Numer. Anal. V15.(1978),p772.(tabIe 7) 

write(*,*) 'Seventh order Runge-Kutta-Verner method' 

a I(1)»1.d0/4.d0 

al(2) = 1.d0/12.d0 

al (3)=1.d0/8.d0 

al(4)=2.d0/5.d0 

al(5)=1.d0/2.d0 

Ol(6)=6.d0/7.d0 

ol(7)=1.d0/7.d0 

a I(8)=2.d0/3.d0 

a I(9)=2.d0/7.d0 

ol(10)=1.d0 

al (11)=1.d0/3.d0 

al(12)=1.d0 

b(1,1)=1.d0/4.d0 

b(1,2)=5.d0/72.d0 

b(2.2)=1.d0/72.d0 

b(1,3)=1.d0/32.d0 

b(3,3)=3.d0/32.d0 

b(1,4)=106.d0/125.d0 

b(3,4)=-408.d0/125.d0 

b(4,4)=352.d0/125.d0 

b(1,5)=1.d0/48.d0 

b(4,5)=8.d0/33.d0 

b(5,5)=125.d0/528.d0 

b(1,6)=-1263.d0/2401.d0 

b(4,6)=39936d0/26411d0 

b(5,6)=-64125.d0/26411d0 

b(6,6)=5520.d0/2401,d0 

b(1,7)=37.d0/392.d0 

b(5,7)=1625.d0/9408.d0 

b(6,7)=-2.d0/15.d0 

b(7,7)=61.d0/6720.d0 

b(1,8)=17176.d0/25515.d0 

b(4.8)=-47104.d0/25515.d0 

b(5.8)=1325.d0/504.d0 

b(6.8)=-41792.d0/25515.d0 

b(7,8)=20237.d0/145800.d0 

b(8,8)=4312.d0/6075.d0 

b(1.9)=-23834.d0/180075.d0 

b(4,9)=-77824.d0/1980825.d0 

b(5,9)=-636635.d0/633864.d0 

b(6,9)=254048.d0/300125.d0 

b(7,9)=-183.d0/7000.d0 

b(8,9)=8.d0/11.d0 

b(9,9)=-324.d0/3773.d0 

b(1,10)=12733.d0/7600.d0 

b(4,10)=-20032.d0/5225.d0 

b(5.101=456485.d0/80256.d0 

b(6,10)=-42599.d0/7125.d0 

b(7,101=339227.d0/912000d0 

b(8,10)=-1029.d0/4180.d0 

b(9,10)=1701.d0/1408.d0 

b(10,10)=5145.d0/2432.d0 

b(1.11)=-27061.d0/204120.d0 

b(4,11)=40448.d0/280665.d0 

b (5,111—1353775. d0/1197504. d0 

b(6,11)=17662.d0/25515.d0 

b (7,111—71687. d0/1166400d0 

b(8,11 )*98. d0/225. d0 (continued) 
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b(9,11)-1.d0/16.d0 
b(10,11)-3773.d0/11664.dO 
b(1,12)»11203.d0/8680.d0 
b(4,12)—38144.d0/11935.d0 
b(5.12)-2354425.d0/458304.d0 
b(6.12)—84046.d0/16275.d0 
b(7,12)»673309.d0/1636800.d0 
b(8.12)-4704.d0/8525.d0 
b(9,12)-9477.d0/10912.d0 
b(10,12)—1029.d0/992.d0 
b(12,12)-729.d0/341,d0 

erl—1 ,d0/480.d0 
er6—16.d0/375.d0 
er7—2401.d0/528000.d0 
er8-2401.d0/132000.d0 
«r9=243.d0/14080.d0 
er10—2401.d0/19200.d0 
erll—19.d0/450.d0 
er12-243.d0/1760.d0 
er13»31.d0/720.d0 

al-31.d0/720.d0 
o6-16.d0/75.d0 
o7-16807.d0/79200.d0 
o8-16807.d0/79200.d0 
09-243.d0/1760.d0 
012-243.d0/1760.d0 
013-31.d0/720.d0 

lnum-13 

ist-7 

I f( i def.eq.0) hmoxl«2.d0 
hiIm1-5.d0 
end if 

power-1.d0/dble(ist+1) 

hfoct-0.5d0**(1.d 0 /dble(ist- 1 )) 

hIim-hIiml/hfoct 
lf(idef.eq.0) hmln-1.d-06 
c wrIte(*,*)’ Constants evaluated* 
return 
end 


epsiIon.for 


$NOFLOATCALLS 

$NODEBUG 

$ST0RAGE:2 

c***********************************************************^***^*** 


subroutine caleps 

c**»* subroutine calculates the machine epsilon EPS using an 
c**»* algorithim adapted from Forsythe et. ol. "Computer Methods 
c*«** for Mathematical Computations", Prentice-Ha11,N.J. (1977). 
c**** The EPS calculated can differ from the true machine EPS by 
c**** at most a factor of 2. 

double precision eps 
common /epsil/eps 

eps-1.d0 

10 eps-.5d0*eps 

if((eps+1.d0),GT.1.d0) goto 10 
c write(*,*) ’Machine Epsilon used-’,eps 

return 
end 
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therm.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
ApriI, page 191. 


implicit double precision (a-h,o-z) 
dimension y(1), work(17), icom(4) 
external thermo 
common etherm,ifevaI,j 

open(2,fiIe=’ *,status=’new’) 

ifeva1=0 

icom(1}=0 

icomf2)=0 

icom(3)=0 

neqn«1 

write(*,*) *etherm», imeth*, tola=, tolr=* 
read(*,*) etherm,imeth,to I a,to Ir 
hstart=0.01d0 
y(1)=1.d0 
x0=0.d0 
xb=0.d0 
do 20 J-1,6 
xa=xb 

xb=0.2d0*dbIe(j)+x0 

abserr=dexp(-etherm*xa)-y(1) 

re Ierr=abserr/dexp(-etherm*xa) 

write(2,100)xa,y(1),abserr,re I err 

cal I runkut(xa,y,xb,neqn,tola,tolr,hstart.work, 

& imeth,ierror,icom,thermo) 

if(ierror.GT.I) then 
write(2,100)xb,y(1),abserr,re I err 

write(2,*)' ERROR-ProbIem too stiff or is discontinous' 
close(2) 
stop 
end i f 
20 continue 

if(icom(4).GT.0) wrlte(2,*) ’Round-off error possible’ 
write(2,*) ’Number of function evaluations = ’.ifeval 
close (2) 
stop 

100 format(F10.5,4E14.6) 

end 

subroutine thermo (x,y,yprime,neqn) 
implicit double precision (a-h,o-z) 
dimension y(neqn), yprime(neqn) 
common etherm,ifevaI,j 

yprime(1)= -etherm*y(1) 
i f(j.LE.5) i fevaI *ifeva1+1 
return 
end 


examp Ier.for 
TEXT 

"The Runge-Kutta Methods," Benku Thomas. 
Apr 1 I , page 191. 


RUNGE KUTTA EXAMPLES. 

Let us look at three examples which we will attempt to solve by 
using the FORTRAN implementations of the algorithms outlined 
in the BYTE article. 

EXAMPLE 1. This is the radlactivlty problem from the article. The 
dimensionless form of the equation was solved, with the decay 
constant set to a value of 25. Since the solution produced values 
close to zero, a relative error tolerance was used, and its value 
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set to 10(-9). The calling (user) program is similar to the 
listing for example 3. The result of running the program with the 
fifth order method is given In table la. For comparison, table 1b 
gives the absolute and relative global errors at each step using 
each of the methods. The total number of function evaluations Is 
a measure of the efficiency of the method and the global error, a 
measure of the accuracy. The expression for the parameter POWER, 
used in the formula for the step size adjustment factor v. was 
1/(P+D. 

TABLE la - Results of solving the equation y’«-25y using the variable 

step size fifth order method. (Relative error tol. - 1.E-09) 


X 

y(x) 

Absolute 
global error 

Re 1 ative 
global error 

0.0 

0.100000E+01 

0.000000E+00 

0.000000E+00 

0.2 

0.673795E-02 

-0 .186541E-11 

-0.276851E-09 

0.4 

0.453999E-04 

-0.250863E-13 

-0.552562E-09 

0.6 

0.305902E-06 

-0.25337IE-15 

-0.828274E-09 

0.8 

0.206115E-08 

-0.227547E-17 

-0.110398E-08 

1.0 

0.138879E-10 

-0.191612E-19 

-0.137970E-08 

Total number 

of function evaluations ■ 

2008 


TABLE 1b - Comparison of the relative global error in the numerical 
solutions of the equation y’=-25y, using the 4th. 5th and 
7th order variable step methods. 

(TOLR = 1.E-09, TOLA » 0.0) 


x RKF-4 


RKV-5 


RKV-7 


0.0 

0.2 

0.4 

0.6 

0.8 

1.0 


0.000000E+00 
0.113247E-08 
0.226672E-08 
0.340097E-08 
0.453523E-08 
0.566949E-08 


0.000000E+00 
-0.276851E-09 
-0.552562E-09 
-0.828274E-09 
-0.110398E-08 
-0.137970E-08 


0.000000E+00 
-0.519695E-09 
-0.107925E-08 
-0.16388IE-08 
-0.219837E-08 
-0.275792E-08 


Total function 3216 2008 1053 

evaIuations 


EXAMPLE 2. The classic stiff problem involving the rate of 
formation of methyl iodide in a nuclear reactor is 
solved, using a reactant inlet temperature of 800 K. The 
temperature of the cooling fluid on the outside of the reactor 
(T/w/) was varied from 400 K to 800 K. The results obtained from 
the numerical solution are plotted in figure 2 for cooling fluid 
temperatures of 400K, 600K, and 800K. This gives the 
dimensionless temperature in the reactor as a function of 
fractional distance down the length of the tubular reactor. From 
the physics of the problem, we know that the reaction gives off 
heat, that the amount of heat released will increase with the 
rate of reaction which in turn is proportional to the amount of 
reactant present. At the inlet of the reactor there is a large 
amountof reactant present, so the rate will be high , resulting 
in a high heat release. The heat is being produced by the 
reaction faster than can be removed by the cooling fluid, so the 
mixture heats up, driving the reaction even faster. However, the 
amount of reactant is also falling down the length of the 
reactor, so eventually the reaction slows down. The heat released 
drops off until a point is reached when the amount of heat 
removed by the cooling fluid just equals the rate of heat 
production from the reaction. The temperature tops off and then 
starts to fall as the rate of reaction drops even further. We see 
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this maximum in the temperature profiles as expected. In 
addition, if the temperature of the cooling fluid is lowered, the 
amount of heat removed increases and so the maximum in the 
temperature will be lower, and will shift towards the inlet. This 
trend too is observed in the profiles. The rate of reaction is 
proportional to the temperature, so we would expect to see less 
reactant in the outlet of the hotter reactor. The (dimensionless) 
outlet concentrations obtained from the program were .03548, 

.03424, and .03321 for the coolant temperatures of 400K, 600K, 
and 800K respectively. Although we do not know the analytical 
solution to this problem, we are able to say that our program is 
producing reasonable results by checking to see if the trends are 
what we would expect. 

EXAMPLE 3. This problem describes the orbit of a satellite. The 
problem statement and the derivation of the differential 
equations are described in Shampine, L.F., and M.K. Gordon, 

COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS: THE INITIAL 
VALUE PROBLEM, Freeman, San Fransisco (1975). For our purposes, we 
will only deal with the final set of equations. They are included in 
the FORTRAN listing for the user supplied programs for this problem. 
The format used for this program is similar to that used for the 
other examples. 

The solutions using the three methods over the range t=0 to t*12 
are given in table 2. A relative error tolerance of 10(—10) was used. 
The values of y/1/ and y/2/ at x*12 should be -1.25 and 0 
respectively. 

NOTE: TABLES 2 & 3 ARE IN SEPARATE FILES ON THIS DISK. THEY 
MUST BE PRINTED OUT IN 132-COLUMN FORMAT TO BE READABLE. 


Table 3 compares the use of the two expressions for the step 
size adjustement factor - that is for the parameter POWER * 1/p 
and 1/(p+1). It would appear from this that the expression that 
contains the term 1/(p+1) is preferrable. Also, the fifth order 
method gives the most accurate results and the seventh order 
method uses the least number of function evaluations (the 
fastest). However, if memory usage is a consideration, the fourth 
order method is the code that requires the least amount of 
memory, and is the easiest to code. 


atomcc.exe 
BINARY 

"The ATOMCC Toolbox," Y. F. Chang. 

April, page 215. If you have and MS-DOS-based system, 
also download cdrdcv.obj crdcv.obj, drdcv.obj, rdcv.obj, 
and manual.doc. For other formats, download atspgm.for 
and painI eve.for . 




c*+*+*+*+*+* 

c This program was produced by the ATOMCC translator version 7.10 
c Copyright (C) 1985, Y. F. Chang 

C*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ 
c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, 
c This program was written for the following inputs 
c 

C FIRST PAINLEVE TRANSCENDENT 
C DIFF(Y,T,2) = 6.0*Y*Y + T 


c no instructions in second Input block 


COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN, 

+ KTRDCV,KNTSTP,KTSTIF.KXPNUM,KDIGS,KENDFG,NTERMS,NOPT 
A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR 
B /CPASS/ START,END,ORDER 
C /DPASS/ H,HNEW,XPRINT,DLTXPT 
DIMENSION TMPS( 36, 1) 

CHARACTER*6 NAMES 
EQUIVALENCE (TMPS(1,1),Y(1)) 

DIMENSION NAMES(1), Y(36), T(2), TMPAA8(30), TMPAAA(30) 

DATA NAMES(1)/*Y.’/ {umUnued) 
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C 

c 

c- 


Y(33) =1.1 

10 F0RMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985. Y. F. Chang: S 

Aolution results./9H ******) 

11 F0RMAT(/5X,1IHStep number,16.13H at the point,1P1E12.4/1X. 

A 9Hvolues of ) 

12 FORMAT MX, A6. (IX, 1P4E13. 5)) 

13 FORMAT(5X,21HStepsize adjusted to .1PE13.5) 

14 FORMAT(/5X,35HThe solution stopped normally after, I4.24H steps as 
a set by nsteps. ) 

16 FORMAT(/5X,63HThe adjustment for stepsize seems to be in a loop P 
Alease try a /5X,22Hshorter series length. ) 

WRITE(*,10) ' 


Initialize variables to default values. 


NSTEPS * 40 
H = 1.E0 
ERRLIM = 1.E- 6 
LENSER = 30 
MPRINT = 4 
NTERMS = 2 
KTRDCV = 1 

ADJSTF - 1.E-2 
MSTIFF = 0 

DLTXPT = 0.E0 


c- 

c start of third input block 


READ INTEGRATION INTERVAL AND INITIAL CONDITIONS 
READ(5,1010) START,END,Y(1),Y(2) 

1010 FORMAT(4F10.3) 

WRITE(*.1020) START,END,Y(1),Y(2) 

1020 FORMAT(* SOLVE THE FIRST PAINLEVE TRANSCENDENT* / 
+ * INTERVAL: \2F10.3 / 

4 * INITIAL CONDITIONS:*,2F10.3 /) 


input block 


c end of third 

c- 

c More initializations 


DLTXPT = SIGN(DLTXPT,(END-START)) 

H = SIGN(H,(END-START)) 

KDIGS = 6 

XPRINT - START + DLTXPT 

KXPNUM = 35 

LENVAR = 36 

LRUN = 1 

KTSTIF - 0 

NUMEQS = 1 

IF(LENSER.GT.(LENVAR- 6)) LENSER = LENVAR - 6 

IF(MPRINT.LT.2) GO TO 17 
WRITE(*,11) KTSTIF,START 
K = Y(33) 

WRITE(*,12) NAMES(K).Y(I), Y(2) 


c Loop for integration steps. Inside the loop, print the desired output 


17 DO 27 KINTS=1.NSTEPS 
KOUNT = 0 
KNTSTP - KINTS 
19 CONTINUE 


T(1) = START 
T(2) = H 
Y(2) = Y(2)*(H) 


c Preliminary series calculations 


TMPAAA(I) = 6.E0*Y(1) 

TMPAAB(1) = TMPAAA(1)*Y(1) 

Y(3) - (TMPAAB(1) + T(1))*(H*H/2.E0) 
TMPAAA(2) - 6.E0*Y(2) 

TMPAAB(2) = TMPAAA(1)*Y(2) + TMPAAA(2)*Y(1) 
Y(4) = (TMPAAB(2) + T(2))*(H*H/6.E0) 
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c Loop for series calculations 


DO 23 K= 5,LENSER 
KA - K - 1 
KB = K - 2 

TMPAAA(KB) * 6.E0*Y(KB) 

TMPAAB(KB) = 0.E0 
KZ = 1 + KB 
DO 30 N=1, KB 
L = KZ - N 

TMPAAB(KB) = TMPAAB(KB) + TMPAAA(N)*Y(L) 
30 CONTINUE 

Y(K) = (TMPAAB(KB))*(H*H/(KB*KA)) 


c Test and adjust H to avoid over/under flow. 


IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 
TMP = ABS(Y(K)) 

IF(TMP.LE.1.E-35) GO TO 23 

IF(TMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 
IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 
KOUNT = KOUNT + 1 
IF(KOUNT.LT.9) GO TO 22 
WRITER.16) 

GO TO 28 

22 CONTINUE 

Y(2) = Y(2)/(H) 

H = H * TMP**(0.3/(1-K)) 

IF(MPRINT.GE.4) WRITE(*,13) H 
GO TO 19 

23 LRUN - 1 


c Calculate radius of convergence and take optimum step. 


CALL RDCV(TMPS.LENVAR.NUMEQS,NAMES) 
24 CALL RSET(TMPS,LENVAR,NUMEQS,NAMES) 


c no instructions in fourth input block 


25 GO TO (26,28,24), KENDFG 

26 H = SIGN(RADIUS.H) 

START = START + HNEW 
IF(MPRINT.LT.4) GO TO 27 
WRITE(*.11) KNTSTP, START 
K = Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 

27 CONTINUE 
WRITE(*,14) NSTEPS 

28 CONTINUE 

29 STOP 
END 


onebody.bos 

TEXT 

"The Runge-Kutto Methods" Benku Thomas. 

April, poge 191. This is Listing A, poge 197, written by David M. Leo. 


OEM N = THE NUMBER OF INTEGRATORS 

20 REM V(I) = INTEGRATOR INPUTS 

30 REM X(I) - INTEGRATOR OUTPUTS 

40 REM X(1) “ VELOCITY; X(2) - DISPLACEMENT 

50 REM C - THE DAMPING CONSTANT 

60 REM M - MASS; K - SPRING CONSTANT 

70 REM TMIN - TIME AT WHICH PRINTING TO OUTPUT FILE BEGINS 

80 REM TMAX - TIME AT WHICH PRINTOUT ENDS 

90 REM DT - TIME STEP SIZE 

100 REM ******************************** 

110 OPEN"OUT.DAT" FOR OUTPUT AS #1 
120 N-2;C-1500:M-2:K-100000! 

130 DIM X(N),K1(N),K2(N),K3(N),K4(N),DUM(N),V(N) 

140 DT-.0001:TMIN-DT:TMAX-500*DT 

150 REM FNX(T) IS THE DRIVING FORCE mtinuect) 
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160 DEF FNX(T)-5000*(SIN(200*T))^5 

170 REM NEXT ARE THE INITIAL CONDITIONS ON VELOCITY,X(1),AND DISPLACEMENT X(2) 
180 X(1)-.001:X(2)-.001 V ' 

190 REM NEXT IS THE EQUATION FOR THE INPUT TO INTEGRATOR #1 
200 REM IN THIS CASE, THERE IS COULOMB DAMPING 
210 V(1)-(FNX(T)-K*X(2)-C*SGN(X(1)))/M:V(2)«X(1) 

220 REM NEXT ARE THE STEPS IN THE INTEGRATION ACROSS ONE TIME STEP 

230 COUNT-COUNT+1:IF COUNT-2 THEN 260:IF COUNT-3 THEN 270:IF COUNT-4 THEN 280 

240 FOR I- 1 TO N:K1(I)-DT*V(I):NEXT I 

250 T-T+DT/2:F0R 1-1 TO N:DUM(I)-X(I):X(I)-DUM(I)+K1(I)/2:NEXT IsIF COUNT-1 


260 FOR I- 1 TO N:K2(I)«DT*V(I):X(I)-DUM(I)+K2(I)/2:NEXT I:IF COUNT-2 THEN 210 
270 FOR 1=1 TO N:K3(I)=DT*V(I):X(I)=DUM(I)+K3(I):NEXT I:T=T+DT/2:IF COUNT-3 
THEN 210 
280 FOR 1-1 TO 


N:K4(I)-OT*V(I):X(I)-DUM(I)+(K1(I)+K4(I))/6+(K2(I)+K3(I))/3:NEXT I 

290 REM NEXT STEPS APPROXIMATE STATIC/DYNAMIC FRICTION 

300 IF ABS(X(1))>.5 THEN 330 

310 C-3000 

320 GOTO 340 

330 C-1500 

340 IF X(2)>1I THEN 440 

350 REM FROM RUNNING THIS A FEW TIMES, WE EXPECT A8S(DISPLACEMENT) < .030 
360 REM OVER THIS RANGE, THE NONLINEAR SPRING RATE CAN BE APPROXIMATED AS 
FOLLOWS: 


370 K=100000!+300000!*(SIN(50*X(2))W 
380 IF T<TMIN THEN 210 

390 PRINT #1,FNX(T):FOR 1-1 TO N:PRINT #1.X(I):NEXT I 

400 IF T>TMAX THEN 420 

410 GOTO 210 

420 CLOSE 

430 GOTO 450 

440 PRINT" DIVERGENT OSCILLATION ENCOUNTERED" 

450 END 


remes.c 
TEXT 

"Computer Approximations," Stephen Moshler. See chbevl.c. 


0 remes.c 
* 

* This Is an interactive program that computes least maximum polynomial 

* and rational approximations. 

*/ 

^define P 15 /* max total degree of polynomials, + 2 */ 

^define N 20 /* number of items to tabulate for display */ 
extern double PI; /* 3.14159... */ 


static int IPS[P] = {0.}; 
static double AA[P*P] * {0.0,}; 
static double BB[P] = {0.0,}; 
static double param[P] = {0.0,}; 
static double xx[P] = {0.0,}; 
static double ref[N+1] * {0.0,}; 
static int n * 0; 
static int d = 0; 
static int ndl * 0; 


/* simq() work vector */ 

/* coefficient matrix */ 

/* right hand side vector */ 

/* solution vector */ 

/* points in approximation interval*/ 
/* function values for display */ 

/* degree of numerator polynomial*/ 

/* degree of denominator polynomial*/ 
/* n + d + 1 */ 


main() 

int l. Ip, j, ncheb, neq, relerr; 
double a, apstrt, apwidt, b, c, x, y, z; 
char s[40]; 

double abs(), approxQ, cos(), funcQ; 
int simq(); 


P r intf( "\nRationaI Approximation by Remes Algorithm\n\n" ); 

START: 

Printf( "Relative error (y or n) ? " ); /* Ask for error criterion */ 

gets( s ); /* read in a line of characters */ 
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printf( "Degree of numerator polynomial? " ); 
gets( s ); /* read line */ 

sscanf( s, "%d", &n ); /* decode characters */ 

printf( "Degree of denominator polynomial? " ); 
gets( s ); 

sscanf( s, "%d", &d ); 


printf ( "Start of approximation interval ? " 
gets( s ); 

sscanf( s, "%E", fcapstrt ); 

printf ( "Width of approximation interval ? " ); 
gets( s ); 

sscanf( s, "%E", fcapwidt ); 
ndl « n + d + 1; 


/* remes.c 2 */ 

/* Supply initial guesses for points in approximation interval */ 


If( d 


e I se 


== 0 ) 

{ /* there is no denominator polynomial */ 

neq = n + 2; /* The number of equations to solve */ 
ncheb « n + 1; /* Degree of Chebyshev error estimate */ 
/* Extrema of Chebyshev polynomial */ 
a * ncheb; 

for( i*0; i<neq; i++ ) 
xx[i] - apstrt 

+ 0.5 * apwidt * (1.0 - cos( (PI * i) / a ) ); 


{ /* there is a denominator polynomial */ 

neq * ndl; 
ncheb * ndl; 

/* Zeros of Chebyshev polynomial */ 

a ■ 2.0 * ncheb; 

for( l»0; icncheb; i++ ) 

{ 

xx[i] * apstrt 

+ 0.5 * apwidt * (1.0 - cos( PI * (2*i+1) / a ) ); 
c - 0.0; /* deviation at solution points */ 


/* calculate function table for error curve display */ 

a - apwidt/N; 

b = apstrt; 

for( i=0; i<«N; i++ ) 

ref[i] * func(b); /* func is the f(x) to be approximated */ 

b +* a; 

* 

/* remes.c 3 */ 

LOOP: 

/* Display old values of guesses and let user change them if desired */ 

/* First do the deviation guess if rational form */ 

I f ( d > 0 ) 

{ /* there Is a denominator */ 

c « abs(c); /* deviation at solution points */ 
printf( "deviation « %.4E ? ", c ); 
gets( s ); 

lf( s[0] !« *\0’ ) /* if input is not a null line, */ 

sscanf( s, "%E", See ); /* then decode the number */ 


[continued) 
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else /* no denomlnotor: */ 

c - 1.0; /* coefficient of the deviation */ 

/* Read in guesses for locations of solution */ 
for( 1-0; l<neq; I++ ) 

prIntf( "x[%d] - %. 4E ? ", I, xx[I] ); 
gets( s ); 

If( s[0] !- # \0’ ) 

sscanf( s, "%E", &x ); 
xx[i] « x; 

/* remes.c 


4 */ 


/* Set up the equations for solution by simq() */ 
for( i=0; I<neq; I++ ) 

ip « neq * I; /* offset to 1st element of this row of matrix*/ 
x = xx[i]; /* the guess for this row */ 

/* right-hand-side vector */ 

y = func(x); /* accurate function value f(x) */ 
lf( d > 0 ) 

{ /* add the deviation If rational form */ 
if( relerr ) /* relative error criterion */ 

y - y * (1.0+c); 

else /* absolute error criterion */ 

^ y » y + c; 

/* insert powers of x[i] for numerator coefficients */ 

2 - 1 . 0 ; 

for( j*0; j<«n; j++ ) 

AA[ip+j] - z; 
z » z * x; 

\ 

/* insert denominator terms, if any */ 

If( d > 0 ) 

i 

z = 1.0; 

for( j-0; j<d; j++ ) 

AA[ip+n+1+j] = -y * z; 
z = z * x; 

BB[T] = y * z; /* right hand side vector */ 

e I se 

J /* no denominator */ 

BB[i] = y; /* right hand side vector */ 
y = c; 

If( relerr ) 

y » y * BB[i]; 

AA[ip+n+1] = y; 

c = -1.0 * c; /* switch sign of deviation for next row */ 

/* Solve the simultaneous linear equations */ 
slmq( &AA[0], &BB[0], &param[0], neq, 0, &IPS[0] ); 


/* 

/* Display the results */ 

j * 0; /* printout variable */ 

ip = 0; /* solution vector counter */ 
printf( "Numerator coefficients:\n" ); 
for( i-0; I<»n; i++, j++, ip++ ) 

if( j > m ? ) 

prlntf( “\n" )-. 


remes.c 


5 */ 
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printf( "%.4E ", param[ip] ); 
if( d > 0 ) 

j = 0; 

printf( "\nDenominator coefficients:\n" ); 
for( i»0; i<d; i++, j++, ip++ ) 

if( j >=^7 ) 

printf( "\n" ); 

pr intf( "%.4E ", param[ip] ); 


e I se 

pr I nt f( "\nDeviatIon: %.4E", paramfip] ); 


/* Display table of function and approximation error */ 

printf( "\n\n x func approx error\n" ); 

a = apwidt/N; 

b = apstrt; 

for( i=0; i<=N; 1++ ) 

x * b + i * a; 
z * approx(x); 
y « z - ref[i]; 
i f( re I err kk (z !« 0.0) ) 

y = y/z; 


pr Intf( "%.3E %.3E %.3E %.3E\n", 

printf( "Another iteration (y or n)? " ) 
gets( s ); 
i f ( s[0] *y' ) 

goto LOOP; 
if( s [0] == ’x* ) 
exit(0); 

e I se 

^ goto START; 


x. ref[i], z. y ); 

/* Ask what to do next 


*/ 


/* 


remes.c 6 */ 


/* This subroutine computes the rational form P(x)/Q(x) 
fusing coefficients from the solution vector param[] 

double approx(x) 
double x; 

{ 

double yn, yd; 

Int I; 


yn = param[n]; /* highest order numerator coefficient */ 

for( i»n-1; i>«0; i— ) /* work backwards toward the constant term */ 
yn ■ x * yn + param[i]; 

I f ( d > 0 ) 

yd » x + param[n+d]; /* highest order coefficient = 1.0 */ 

for( i«n+d-1; 1>n; i— ) 

^ yd - x * yd + param[i]; 

e I se 

yd ■ 1.0; /* if there is no denominator */ 
return( yn/yd ); 


/* Put here an accurate routine for the function 
* to be approximated 

(continued) 

\ 
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double func(x) 
double x; 

double cos(), sqrt(); 
double y; 

y - sqrt(x); 

return( cos(PI * y / 2.0) ); 


Screen #1 

( begin Dragon curve ) 

CREATE CURVE ( a FORGETabIe name) 

CARTESIAN OFF 

: RECURS SMUDGE ; IMMEDIATE ( trick verb for recursion) 

VARIABLE ANGLE 
VARIABLE XCOOD 
VARIABLE YCOOD 
VARIABLE STEPSIZE 

: TURN ( deltangle— | turn slgn*delta) 

ANGLE +! ; 

2 4 THRU 


Screen #2 

: MOVE ( — | takes a step In present turtle direction) 
STEPSIZE @ DUP 

ANGLE e COS * 10000 / ( r* cos of theta) XCOOD @ + 

DUP ( newX) XCOOD ! ( update X) 

SWAP 

ANGLE e SIN * 10000 / ( r* sine theta ) YCOOD @ + 

DUP ( newY) YCOOD l ( update Y) 

DRAW.TO ; 


Screen #3 

: DRAGON ( sign level— | ) 

DUP ( level) 0= 

IF ( at bottom of recursion) 

DROP ( level) DROP ( sign) MOVE ( by stepsize) 
ELSE 

OVER 45 * TURN ( getsign and turn) 

1 ( newsign) 

OVER 1- ( I eve I = I eve 1-1) 

RECURS DRAGON RECURS 

OVER -90 * TURN ( getsign & turn) 

-1 ( newsign) ( edit to +1 for diff curve) 

OVER 1- ( level-level-1) 

RECURS DRAGON RECURS 

DROP ( Input level) 45 * TURN ( getsign and turn) 
THEN ; 


Screen #4 

: DCURVE (level —| ) 

( Inlt pen position) 

PAGE 100 XCOOD I 90 YCOOD ! 360 6 * ANGLE I 

WHITE PENPAT XCOOD @ YCOOD @ MOVE.TO 

PEN.NORMAL 
1 STEPSIZE ! 

1 SWAP ( level) DRAGON 

WHITE PENPAT 4 10 MOVE.TO PEN.NORMAL ; 
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s imq.c 
TEXT 

"Computer Approximations," Stephen Moshier. See chbevl.c. 


0 

* Solution of simultaneous linear equations AX = B 

* by Gaussian elimination with partial pivoting 

* 

♦ 

* 

* SYNOPSIS: 

* 

* double A[n*n], B[n], X[n]; 

* int n, flag; 

* int IPS[1; 

* Int simqQ; 

* 

* ercode « simq( A, B, X, n, flag, IPS ); 

♦ 

* 

* 

♦ DESCRIPTION: 

♦ 

* B, X, IPS are vectors of length n. 

* A is an n x n matrix (i.e., a vector of length n*n), 

* stored row-wise: that is, A(i,j) « A[ij], 

* where ij = i*n + j, which is the transpose of the normal 

* column-wise storage. 

* 

* The contents of matrix A are destroyed. 

* 

* Set flag=0 to solve. 

* Set flag=-1 to do a new back substitution for different B vector 

* using the same A matrix previously reduced when flag=0. 

* 

* The routine returns nonzero on error; messages are printed. 

* 

♦ 

♦ ACCURACY: 

* 

* Depends on the conditioning (range of eigenvalues) of matrix A. 

♦ 

♦ 

* REFERENCE: 

* 

* Computer Solution of Linear Algebraic Systems, 

* by George E. Forsythe and Cleve B. Moler; Prentice-Hall, 1967. 


int simq( A, B, X, n, flag, IPS ) 
double A[], B[j, X[]; 
int n, flag; 


int i, j, IJ, ip, ipj, ipk. ipn; 
int idxpiv, iback; 
int k, kp, kpl, kpj, kpk, kpn; 
int nip, nkp, nml; 

double em, q, rownrm, big, size, pivot, sum; 
double abs(); 

l f ( f lag < 0 ) 

goto solve; 

/* Initialize IPS and X */ 

I J-0; 

for( i-0; I<n; I++ ) 

IPS[I] - I; 

rownrm - 0.0; 

for( j-0; J<n; J++ ) 

^ ( continued) 
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/* 

/♦ 

nml 


q - obs( A[IJ] 

1 1 ( rownrm < q 

rownrm * q; 

r 1J: 

if( rownrm ■■ 0.0 ) 

puts("SIMQ ROWNRM®0"); 
return(1); 

X[i] * 1.0/rownrm; 

Gaussian elimination with partial pivoting 


n-1; 

for( k=0; k<nm1; k++ ) 
bIg= 0.0; 

for( i-k; I<n; i++ ) 

ip - IPS[I]; 

Ipk = n*ip + k; 

size ■ abs( A[ipk] ) * X[Ip]; 

I f ( size > big ) 

big = size; 

Idxplv * I; 

• 1 


*/ 


I f( big — 0.0 ) 

pu18( “SIMQ BIG-0" ); 
return(2); 

I f ( Idxpiv !« k ) 

j - IPS[k] ; 

IPS[k] - IPS[idxpiv]; 

IPS[ldxpIv] - j; 

kp = IPS[k]; 
kpk ■ n*»«kp + k; 
pivot - A[kpk]; 
kpl = k+1; 

for( i=kp1; i<n; I++ ) 

ip - IPS[i]; 

Ipk * n*ip + k; 
em » -A[ipk]/pivot; 

A[ipk] = -em; 
nip = n*ip; 
nkp = n*kp; 

for( J-kpl; j<n; j++ ) 
ipj = nip + J; 

A[< p j] - A[ipj] + em * A[nkp + j]; 


kpn = n * IPS[n— 1 3 + n - 1; /* lost element of IPS[n] th row */ 

if( A[kpn] =» 0.0 ) 

puts( "SIMQ A[kpn]=0"); 
return(3); 

/* 

/* back substitution */ 

solve: 

ip = IPS[0]; 

X[0] = B[ip]; 

for( i»1; i<n; i++ ) 
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ip ° 
i P j 
sum 
for ( 


X[i] 


IPS[ i ]-; 
n * ip; 

0 . 0 ; 

j=0; J<i; j++ ) 

sum += A[ipj] * X[j]; 
++ipj; 

= b|i P ] - sum; 


ipn * n * IPS[n-1] + n - 1; 

X[n-1] - X[n-1]/A[ipn]; 

for( Iback*1; iback<n; iback++ ) 

/* i goes (n-11 */ 

i = nml - iback; 

Ip - IPS[i]; 
nip = n*ip; 
sum = 0.0; 

for( j«i+1; j<n; j++ ) 

sum +* A[nip+j] * X[j]; 
X[f] ■ (X[i] - sum)/A[nip+iJ; 

return(0); 


List!ng4.pas 
TEXT 

Programming Project: "A Simple Windowing System, Part 2: 
Implementation," Bruce Webster. 

April, page 96. Listing 4, page 101. Apple Pascal. 


BBuf"[Of fset+3] :* Height; 

DoXfer(Save,Buffer); 

OldOff :« Offset; 

Offset := Offset + Size; 

BBuf"[Of fset-11 :« OldOff div 256; 
BBuf~[0ffset-2J OldOff mod 256; 
BufUsed :* True 
end; 

XI XI * PPB; X2 X2 * PPB; 
Viewport(XI,X2,Y1,Y2); 

Fi I IScreen(White); 

ViewPort(X1+2.X2-2,Y1+1,Y2-1); 

Fi I IScreen(Black) 
end; j of proc OpenWindow { 


procedure CloseWindow(var Error : Integer); 
var 


XI.X2.Y1,Y2,Width,Height : Integer; 
beg i n 

(* error checking again omitted for space *) 
Offset OldOff; 

DoXfer(Restore,Buffer) ; 

If Offset * 0 

then BufUsed :« False 


else with Buffer do 

OldOff 256*BBuf^[Offset-1] + BBuf"[Offset-2]; 

If BufUsed then with Buffer do begin 


XI 
Y1 

Width 
Height 
X2 
Y2 


BBuf"[01dOff] * PPB; 

BBuf " ‘oldOff + r 
BBuf" 0 1 dOf f+2 
BBuf "[01dOf f+3 
XI + PPB*Width - 1 
Y1 + Height - 1; 


ViewPo r t(X1+2,X2-2,Y1 +1,Y2-1) 
end 

else VlewPort(0,279,0,191) 
end; { of proc CloseWindow j 


( continued) 
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procedure Initialize; 
beg I n 

InitTurtIe; 

Offset 0; OldOff 0; 
BufUsed :■ False 
end; ) of proc Initialize } 


[LISTING 4] 
0onst 

XMln 

0 

XMax 

m 

39 

YMin 

m 

0 

YMax 

= 

191 

PPB 

= 

7 

BufAddr 

m 

16384 

BufSize 

m 

16383 


type 

Byte = 0..255; 

Direction = (Save.Restore); 

ByteBuffer * packed array[0..BufSIze] of Byte; 
BufRec * 

record 

case Boolean of 

False : (Addr : Integer); 

True : (BBuf : ^ByteBuffer) 

end; 


var 

BufUsed : Boolean; 

Buffer ; BufRec; 

Offset,01dOff: Integer; 


function ScrAddr(Line : Integer) : Integer; 
var 

Addr,Temp : Integer; 

beg i n 

Line :■ 191 - Line; 

Addr 8192 + 1024 * (Line mod 8); 

Temp :■ (Line div 8) mod 8; 

Line :* Line div 64; 

ScrAddr :« Addr + 128 * Temp + 40 * Line 
end; { of func ScrAddr } 


function DoXfer(Dir : Direction; var Buffer : BufRec); 
var 

XI,Y1.Y2.Width,Height,BStart,Line : Integer; 

TBuf : BufRec; 

begin 

with Buffer do begin 

XI := BBuf^[Offset]; 

Y1 := BBuf^[Of fset + 11; 

Width := BBufn0ffset+2l; 

Height := BBuf~[0ffset+3J; 

BStart ;= Offset + 4; 

Y2 :* Y1 + Height - 1; 
for Line := Y1 to Y2 do begin 
TBuf.Addr ;« ScrAddr(Line); 
if Dir * Save 

then MoveLeft(TBuf.BBuf*[X1],BBuf A [BStart],Width) 
else MoveLeft(BBuf~[BStart],TBuf.BBuf*[XI].Width) 
BStart := BStart + Width 

end 

end 

end; { of proc DoXfer } 


procedure 0penWindow(X1,Y1.Width,Height : Integer; 

var Error : Integer); 


var 

Size,X2,Y2 : Integer; 
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beg I n 
Size 
X2 
Y2 


6 + Width*Height; 

XI + Width - 1; 

Y1 + Height - 1; 

(* error checking goes here — 
with Buffer do begin 


removed for space 


BBuf^[Offset 
BBuf~[Offset+1 
BBuf~[0f fset+2 


XI; 

Y1; 

Width; 


*) 


chbevI.c 
TEXT 

"Computer Approximations," Stephen Moshier. 

April, page 161. Also download cheby.c, remes.c, and simq.c. For related 
modules, see the Cephes subsection of the C+UNIX file area. 


0 chbevI.c 

♦ 

♦ Evaluate Chebyshev series 

* 

♦ 

* 

* SYNOPSIS: 

* 

* int N; 

* double x, y, coef[N], chebevlQ; 

* 

* y « chbevl( x, coef, N ); 

* 

* 

★ 

* DESCRIPTION: 

★ 

* Evaluates the series 

♦ 

* 

* 

* y 

* 

* 

♦ 

* of Chebyshev polynomials Ti at argument x/2. 

* 

* Coefficients are stored in reverse order, i.e. the zero 

* order term is last in the array. Note N is the number of 

♦ coefficients, not the order. 

♦ 

* If coefficients are for the interval a to b, x must 

* have been transformed to x -> 2(2x - b - a)/(b-a) before 

* entering the routine. This maps x from (a, b) to (-1, 1), 

* over which the Chebyshev polynomials are defined. 

* 

* If the coefficients are for the inverted interval, in 

* which (a, b) is mapped to (1/b, 1/a), the transformation 

* required is x -> 2(2ab/x - b - a)/(b-a). If b is infinity, 

* this becomes x -> 4a/x - 1. 

* 

* 

♦ 

* SPEED: 

* 

* Taking advantage of the recurrence properties of the 

* Chebyshev polynomials, the routine requires one more 

* addition per loop than evaluating a nested polynomial of 

* the same degree. 

* 

*/ 

/* chbevl.c */ 


N-1 
_ » 

- > coef[i] T (x/2) 

i 

i *=0 


[continued) 
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/* * Cephas Math Library Release 1.1: March, 1985 

♦ Copyright 1985 by Stephen L. Moshler 

* Contributed to BIX for personal, noncommercial use only. 

★ Direct Inquiries to 30 Frost Street, Cambridge, MA 02140 */ 

double chbevl( x, array, n ) 
double x; 
double array[]; 

Int n; 

doubIe b0, b1. b2, *p; 

Int I; 

p = array; 
b0 « *p++; 
bl - 0.0; 

I ■ n - 1; 

do 

i 

b2 = bl; 
bl - b0; 

b0 » x * bl - b2 + *p++; 

} 

while( —i ); 
return( 0.5*(b0-b2) ); 


cheby.c 
TEXT 

"Computer Approximations," Stephen Moshier. See chbevl.c. 


'* 

>u 

i 

:o 

I 

vh 


cc 

/< 

h 

pi 

X 

y 

ii 


r 

pi 

,s 

P' 

I 

wl 


0 cheby.c 

♦ 

* Program to calculate coefficients of the Chebyshev polynomial 

* expansion of a given Input function. The algorithm computes 

* the discrete Fourier cosine transform of the function evaluated 

* at unevenly spaced points. Library routine chbevl.c uses the 

* coefficients to calculate an approximate value of the original 

* function. 

* — S. L. Moshier 
*/ 

extern double PI; 
extern double PI02; 
double cosi[331 * {0.0,|; 
double func[65J - {0.0,{; 

main() 

double c, r, s, t, x, y, z, 
double low, high, dtemp; 
long n; 

Int l, M, J, n2, k, rr, invflg; 
short *p; 
char st[40]; 

double cos(), log(), exp(), sqrt(); 

/* low end of approximation interval */ 

/* high end */ 

/* set to 1 if inverted interval, else zero */ 
interval goes from 1/high to 1/low */ 

/* will find 64 coefficients */ 

/* but use only those greater than roundoff error */ 


low « 0.0; 
high - 1.0; 
i nvfIg = 0; 

/* Note: inverted 
z = 0.0; 
n = 64; 

n2 « n/2; 
t * n; 
t « PI/t; 


/* 3.14159... */ 

/* cosine array for Fourier transform */ 
/* values of the function */ 

temp; 


/ 


/ 

/ 


/ 
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/* calculate array of cosines */ 
puts("caIcuI ating cosines"); 
s = 1.0; 
cosi[0] = 1.0; 
i = 1; 

while( i <32 ) 

y = cos( s * t ); 
cosi[i] = y; 
s += 1.0; 

++i; 

cosi[32] = 0.0; 

/* cheby.c 2 */ 

/* calculate function at special values of the argument */ 

puts("caIcuI ating function values"); 
x * low; 
y - high; 

I f ( invflg && (low !« 0.0) ) 

{ /* inverted interval */ 

temp « 1.0/x; 
x = 1.0/y; 
y ** temp; 

r = (x + y)/2.0; 

printf( "center %.15E ", r); 

8 “ (y - *)/2.0; 

prIntf( "width %.15E\n", s); 
i - 8; 

whil«( I < 65 ) 

if( i < n2 ) 

c - cosi[i]; 

e I se 

c - -cosi[64-i]; 
temp * r + s * c; 

/* if inverted interval, compute function(1/x) */ 
if( invflg && (temp l* 0.0) ) 
temp « 1.0/temp; 

prIntf( "X.15E ", temp ); 

/* insert call to function routine here: */ 

/♦***♦*♦***+*+****♦♦*****♦*♦*++♦**♦/ 

1 f( temp *= 0.0 ) 

y - 1.0; 

e I se 

y « exp( temp * log(2.0) ); 

/♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦★♦♦♦♦♦♦♦♦♦♦♦♦♦/ 
func[i1 = y; 
printf( "X.15E\n", y ); 

++i; 

/* cheby.c 3 */ 

puts( "calculating Chebyshev coefficients"); 
rr » 0; 

whiIe( rr < 65 ) 

z » func[0]/2.0; 

J - i; 

whi le( J <65 ) 

k - (rr * J)/n2; 
i ■ rr * J - n2 * k; 
k &- 3; 

if( k — 0 ) 

c ■ cos i [ i ]; 
lf( k — 1 ) 

^ {continued) 
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I - 32-1; 
c ■ -cosi[I]; 
lf( I — 32 ) 

I c - -c; 

lf( k -2 ) 

c * -cosi[! 1; 

■«*> 

i - 32-!; 
c ■ cos I [ I ]; 

I 

ff( I !- 32) 

i 

temp * func[j]; 
temp » c * temp; 
z +* temp: 

\ 

r Js 

If( I !- 32 ) 

temp /* 2.0; 
z « z - temp; 

2 *- 2 . 0 ; 
temp ■ n; 
z /■ temp; 
dtemp « 2 ; 

++r r; 

sprIntf( st. V* X.16E */". dtemp ); 
P u ts( st ); 


otspgm.for 
TEXT 

"The ATOMCC Toolbox," Y. F. Chang. See atomcc.exe. 


c*+*+*+★+*+* 

c This program was produced by the ATOMCC translator version 7.10 

c Copyright (C) 1985, Y. F. Chang 

0 *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+♦+*+*+*+*+*+*+ 

c Portions (c) Copyright. Microsoft Corp., 1981. All rights reserved, 
c This program was written for the following inputs 
c 

C FIRST PAINLEVE TRANSCENDENT 
C DIFF(Y,T,2) = 6.0*Y*Y + T 


c no instructions in second input block 


COMMON /IPASS/ LENSER.LENVAR.MPRINT.MSTIFF,LRUN, 

+ KTRDCV. KNTSTP. KTSTIF. KXPNUM, KDIGS, KENDFG. NTERMS. NOPT 
A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR 
B /CPASS/ START.END.ORDER 
C /DPASS/ H,HNEW,XPRINT,DLTXPT 
DIMENSION TMPS( 36. 1) 

CHARACTER*6 NAMES 
EQUIVALENCE (TMPS(1,1),Y(1)) 

DIMENSION NAMES(I). Y(36). T(2). TMPAAB(30), TMPAAA(30) 

DATA NAMES( 1 )/’Y.’/ 

Y(33) =1.1 

10 F0RMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; S 

Aolution results./9H ******) 

11 F0RMAT(/5X.IIHStep number,16,13H at the point,1P1E12.4/1X, 

A 9Hvalues of ) 

12 FORMATfIX, A6,(IX,1P4E13. 5)) 

13 F0RMAT(5X,21HStepsize adjusted to .1PE13.5) 
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14 FORMAT(/5X,35HThe solution stopped normally after, I4,24H steps as 
a set by nsteps. ) 

16 FORMAT(/5X,63HThe adjustment for stepsize seems to be in a loop. P 
Alease try a /5X,22Hshorter series length. ) 

WRITE(*,10) 


c Initialize variables to default values. 


NSTEPS = 40 
H = 1.E0 
ERRLIM = 1.E- 6 
LENSER = 30 
MPRINT « 4 
NTERMS = 2 
KTRDCV * 1 

ADJSTF « 1.E-2 
MSTIFF * 0 

DLTXPT « 0.E0 


c start of third input block 


READ INTEGRATION INTERVAL AND INITIAL CONDITIONS. 

READ(5,1010) START,END,Y(1),Y(2) 

1010 F0RMAT(4F10.3) 

WRITE(*,1020) START,END,Y(1),Y(2) 

1020 FORMAT(’ SOLVE THE FIRST PAINLEVE TRANSCENDENT * / 
+ * INTERVAL: *,2F10.3 / 

+ # INITIAL CONDITIONS:*.2F10.3 /) 


c end of third input block 


c More initial!zations 


DLTXPT - SIGN(DLTXPT,(END-START)) 

H - SIGN(H,(END-START)) 

KDIGS * 6 

XPRINT * START + DLTXPT 

KXPNUM - 35 

LENVAR - 36 

LRUN - 1 

KTSTIF * 0 

NUMEQS = 1 

IF(LENSER.GT.(LENVAR- 6)) LENSER « LENVAR - 6 

IF(MPRINT.LT.2) GO TO 17 
WRITE(*,11) KTSTIF,START 
K « Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 


c Loop for integration steps. Inside the loop, print the desired output 


17 DO 27 KINTS-1,NSTEPS 
KOUNT - 0 
KNTSTP - KINTS 
19 CONTINUE 

T(1) - START 
T(2) - H 
Y(2) * Y(2)*(H) 


c Preliminary series calculations 


TMPAAA(I) * 6.E0+YM) 

TMPAAB(l) - TMPAAA(1)*Y(1) 

Y(3) » (TMPAAB(I) + T(1))*(H*H/2.E0) 
TMPAAA(2) « 6,E0*Y(2) 

TMPAAB(2) - TMPAAA(1)*Y(2) + TMPAAA(2)*Y(1) 
Y(4) - (TMPAAB(2) + T(2))^(H*H/6.E0) 


c Loop for series calculations 


DO 23 K- 5,LENSER 
KA - K - 1 
KB ■ K — 2 

TMPAAA(KB) - 6.E0*Y(KB) 
TMPAAB(KB) - 0.E0 
KZ - 1 + KB 
DO 30 N-1, KB 
L - KZ - N 
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TMPAAB(KB) - TMPAAB(KB) + TMPAAA(N)*Y(L) 
30 CONTINUE 

Y(K) - (TMPAAB(KB))*(H*H/(KB*KA)) 


c Test ond adjust H to avoid over/under flow. 


IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 
TMP - ABS(Y(K)) 

IF(TMP.LE.1.E-35) GO TO 23 

IF(TMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 
IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 
KOUNT = KOUNT + 1 
IF(KOUNT.LT.9) GO TO 22 
WRITE(*,16) 

GO TO 28 

22 CONTINUE 

Y(2) = Y(2)/(H) 

H = H * TMP**(0.3/(1-K)) 

IF(MPRINT.GE.4) WRITE(*,13) H 
GO TO 19 

23 LRUN - 1 


c Calculate radius of convergence and take optimum step. 


CALL RDCV(TMPS,LENVAR,NUMEQS.NAMES) 
24 CALL RSET(TMPS,LENVAR,NUMEQS,NAMES) 
c- 

c no instructions In fourth Input block 


25 GO TO (26,28,24), KENDFG 

26 H = SIGN(RADIUS.H) 

START - START + HNEW 

IF(MPRINT.LT.4) GO TO 27 
WRITE(*.11) KNTSTP, START 
K = Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 

27 CONTINUE 
WRITE(*,14) NSTEPS 

28 CONTINUE 

29 STOP 
END 
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Chapter 1 
Int roduction 


This chapter Is written to help you become familiar with the 
purpose and requirements of the ATOMCC system and with the 
organization of this manual. 


1.1 The Major Advancements in this Version 


The present version of ATOMCC, 7.10 for micros, contains a 
major advancement. Now, the ATOMCC system will solve stiff 
problems. This represents a significant departure from the central 
premise of the ATOMCC system, which is precise error control. For 
non-stiff problems, the user still have the most accurately 
controlled numerical method ever developed. For many problems, the 
precision Is so good that there is ALMOST global error control. 

For stiff problems, due to the nature of the "approximating" 
solution, there cannot be true error control. Therefore, the 
controlling parameter for errors in stiff problems is called 
ADJSTF. It is only meant to be an adjusting constant that can be 
loosely refered to as an error control. 

There is also another particularly useful feature in the 
current version. All the dependent variables are now placed into a 
temporary two-dimensional array (TMPS) by an EQUIVALENCE 
statement. This allows the user to reference each variable by an 
index value. For a system with x, y, and z as functions of t, the 
term y(5) can be also refered to as TMP$(5,2). Similarly, z(23) = 
TMPS(23,3). 


1.2 Purpose and Requirements of the Translator 


The ATOMCC system is a tool to be used in the solution of all 
initial value problems in ordinary differential equations, (stiff 
as well as non-stiff). It is simple enough to be used by students, 
practical enough to be used by engineers, and versatile enough to 
be used by research mathematicians. 

The ATOMCC package is delivered on floppy disks. It uses 
Microsoft-F0RTRAN77 (a registered trademark of Microsoft Corp.) 
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and works on a micro-computer operating under MS-DOS. With the 
ATOMCC system, you now have in your possession a research tool 
whose capabilities far exceed those of standard numerical 
integration methods available on main-frame computers. To be able 
to run ATOMCC on your MSDOS micro-computer, you must have the 
following hardware and software:- 


- an MSDOS computer, with an 8087 co-processor; 

- at least 256K of RAM memory; 

- two floppy disc drives, or a hard disc drive; 

- the Microsoft-F0RTRAN77 version 3.30. 


A complete system includes the following disc files. 


- The ATOMCC system files are:- 


ATOMCC.EXE 


RDCV.OBJ 

DRDCV.OBJ 

CRDCV.OBJ 

CDRDCV.OBJ 


This is the ATOMCC compiler that reads 
statements of differential equations and 
generates an object FORTRAN program called 
ATSPGM. The name ATSPGM for the object program 
file is fixed, but you may change it after it 
has been written by ATOMCC. 

This is the ATOMCC subroutine library in 
singI e-precision. 

This is the ATOMCC subroutine library in 
doubIe-prec1sion. 

This is the ATOMCC subroutine library in 
comp I ex. 

This is the ATOMCC subroutine library in 
comp Iex-doubIe. 


- The Microsoft-F0RTRAN77 files are descripted in the Microsoft 
manual. The relevant files are:- F0R1.EXE, PAS2.EXE, 

LINK.EXE, and FORTRAN.LIB. 


Throughout the discussions in this User Manual, we shall assume 
that all of the ATOMCC system files are on the A: floppy-disk 
drive, and the Microsoft-F0RTRAN77 files are on the B: drive. 


1.3 AppIicabiIity 


- The ATOMCC method can solve: 

* systems of stiff and non-stlff systems of initial value 
problems In ordinary differential equations in which 
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* the highest order derivative of each dependent variable 

is given explicitly on the left hand side of an equation, 
whose right hand side has a finite sequence of +, — * 

/•**• Exp - SIN. COS. TAN. SINH. COSH, TANH, ALOG, ACOS, 
ASIN, ATAN, or any function which is the solution to a 
differential equation. 

- The known limitations of ATOMCC are: 

* the derivatives may be of order at most 6, and 

* there are at most 900 equations in the system. 

- ATOMCC can also solve (with manual intervention): 

* solutions which are polynomials, 

* singular problems which require the application of 
I'HopitaI *s rule, or 

* problems which have catastrophic subtractive errors in 
series generation. 

- ATOMCC is most attractive for:— 

* problems with stringent accuracy requirements, 

* stiff problems, 

* problems which must be solved repeatedly (such as 
parameter identification), or 

* quick and easy problems (students* assignments). 

The very high order and precise error control used by ATOMCC 
have enabled it to solve many problems which other methods 
were unable to solve. 

- The ATOMCC compiIer a I Iows for the solution of ODE’s in the 
complex domain. This unique capability can be used to explore 
the structure of the singularities in the complex domain of 
non-linear problems. The analytic information about the 
location and order of singularities in the solution provides 
insight into the behavior of the system. This method has been 
used to map the first mathematical natural boundary discovered 
in the solution of a nonlinear dynamics problem (7). 

- The complexity and execution time of ATSPGM depend on the 
number of functions and on the number of multiplications in 
the ODE system, not on the number of equations in the ODE 
system nor on the order of the derivatives involved. There is 
no penalty for high-order derivatives. 

- As with all numerical methods, there is no substitute for 
insight into the structure of the ODE system and for the 
application of clever transformations. 
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Solutions which are entire (have no singularities in the finite 
plane), should not be solved using the ATOMCC system. It is a 
total waste of computing power to solve linear problems using 
ATOMCC. This is particularly true for linear 'stiff 1 problems. 

It can be EASILY show that ALL solutions that are entire can be 
solved in quasi-closed forms. This INCLUDES two-point boundary 
value problems! 

Some special circumstances, which rarely occur, are identified 
either by ATOMCC or by the series analysis software, and an 
appropriate message is produced. In such cases, the user should 
examine the series (using MPRINT=10 in the third block), and seek 
the advice of the authors. 


1.4 System Overview 


1.4.1 The Translator, ATOMCC 

The ATOMCC translator is an ODE-solving compiler written in 
FORTRAN. The ODE system to be solved is written into the ODEINP 
input file using conventions discussed in Chapters 2 and 3. The 
name ODEINP for the input file is fixed within ATOMCC; you must use 
this name. ATOMCC reads ODEINP and produces a FORTRAN object 
program, called ATSPGM. The name ATSPGM for the object program is 
also fixed; you must have a file by this name on your disc even if 
it is an empty file. The numerical solution to the ODE system is 
obtained by compiling and executing ATSPGM together with the 
library subroutine RDCV.OBJ or one of its variants. 

ATOMCC accepts four blocks of data from ODEINP in which the 
user specifies the differential equations, the integration 
interval, initial conditions, and various other parameters to be 
used in the solution. The first block is used to specify the 
differential equations and commands to ATOMCC. The second through 
fourth blocks are used to insert statements directly into ATSPGM. 
The third block is required to specify the integration interval and 
the initial conditions. Detailed guidelines for the use of each 
block appear in Chapter 3. 


1.4.2 Tha Object Program, ATSPGM 

The ATSPGM object program implements the Taylor series 
algorithm for solving initial value problems in ordinary 
differential equations. This Taylor series algorithm is outlined 
be Iow. 

- Initialize method control parameters which may be modified. 

- Assign initial conditions, the integration interval, and 
method control parameters. 
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- Initialize method control parameters which may not be 
modified. 

- Loop for each integration step. 

* Initialize the first few series terms. 

* Generate the entire series. 

* Call subroutine RDCV to determine the optimal stepsize 
from (a)the location and order of the primary 
singularities, fbHhe series length, (c)the error 
tolerance, and (d)adjust the stepsize. 

* Call subroutine RSET to perform analytic continuation, 
and to print the solution. 

In ATSPGM, the stepsize used to expand the series is related to 
the radius of convergence at each integration step. After a series 
Is generated, the location and order of the primary singularity are 
calculated. Then, the stepsize is adjusted to control the error in 
the following manner. The terms of the series for a function g(x) 
expanded at Xo with a stepsize of H :« X-Xo are stored as reduced 
derivatives, G(k+1) : = G(k) (Xo) H**k/kl. The stepsize H can be 
varied to control the error by multiplying G(k+1) by (HNEW/H)**k. 

An exception is made In the solution of stiff problems. The 
step-size is determined in stiff problems by the length of a 
polynomial that can adequately represent the function. 

A method which uses an infinite Taylor series is A-stable; 
however, in practice the series must be truncated to N terms. 

Then, the characteristic polynomial is p(x,y) - x - Sum[y(k)/kI]. 
For example, the real-valued stability intervals are (-8.85,0), 
(-12.58,0), and (-16.29,0) for N ® 20, 30, and 40, respectively. 
Taylor series methods are best suited to solve problems with high 
accuracy. However, since very high order derivatives are used in 
these methods, the solution of stiff problems can be easily solved 
using the approximation of a polynomial with an exponential. 


1.5 Purpose of the User Manual 


This ATOMCC User Manual is designed to support easy, and 
efficient use of the ATOMCC system. Chapter 2 may be used as a 
tutorial; the rest of this User Manual is written as a reference 
manual, not as a tutorial, so information is repeated as 
appropriate when it applies to different issues. 

Chapter 1 presents an overview of the ATOMCC system to help you 
understand how Its components fit together. This information is 
helpful to using the system as described in the rest of the 
manual. A more detailed discussion can be found in references (3) 
and (5). 
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Chapter 2 is written as a tutorial for new users of the ATOMCC 
system. Its purpose is to show you how to use the ATOMCC system to 
solve initial value problems in ODE’s. It assumes that you are 
familiar with FORTRAN programming, and with the concept of comput¬ 
ing a solution to a system of ODE’s. It gives examples showing how 
to solve some specific differential equations. 

Chapter 3 is written for users who already have some experience 
using the ATOMCC system. This chapter is the heart of this User 
Manual. It attempts to show you how to use each of the features 
available from the ATOMCC translator and from the ATSPGM object 
program. It is organized for reference, not for sequential 
reading. 
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Chapter 2 
For New Users 


This Chapter is written for new users of the ATOMCC system. 
Its purpose is to show how to use this system to solve initial 
value problems in ordinary differential equations. Here, we give 
some specific examples of how to solve a system of differential 
equations. More detailed explanations are found in Chapter 3. 


2.1 Task of the ATOMCC Translator 


The ATOMCC system is a tool to help you solve differential 
equations. It consists of two major components:- a translator 
program (ATOMCC.EXE), and a subroutine object library (RDCV, DRDCV, 
CRDCV, CDRDCV). To understand the operation of these two 
components, you must first understand the six steps involved in 
using the system. We discuss the purpose of each step briefly, to 
acquaint you with the terms used in the detailed discussion in 
Section 2.2. 

At Step 1 (edit ODEINP), the system of differential equations 
are stated in the form which ATOMCC expects. The input file ODEINP 
contains four separate blocks. (The name ODEINP is fixed within 
ATOMCC; so you must use this name.) The first block contains the 
differential and algebraic equations. ATOMCC compiler processes 
the data in this block to produce a FORTRAN object program ATSPGM 
which is then compiled and executed to solve the problem. (The 
name ATSPGM is also fixed within ATOMCC.) The second, third, and 
fourth blocks are copied unchanged from ODEINP to predetermined 
locations In ATSPGM. 

At Step 2 (run ATOMCC), ATOMCC (a)reads the first block from 
ODEINP, (b)analyzes the differential equations, and (c)copies the 
second, third, and fourth blocks from ODEINP directly into ATSPGM 
at locations shown by examples below. 

At Step 3 (compile ATSPGM), the ATSPGM program is compiled 
using Microsoft-FORTRAN ver 3.30 compiler. 

At step 4 (link ATSPGM k RDCV), ATSPGM.OBJ is linked with the 
ATOMCC subroutine library RDCV.OBJ and FORTRAN.LIB to produce an 
executable module, ATSPGM.EXE. 

The recommended manner to supply the initial conditions, the 
interval of integration, and control parameters is to read them 
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from a data file which you prepare at Step 5. The format of this 
data file Is completely under your control, as shown by examples 
below. Step 5 may be done at any time before Step 6, and it may be 
omitted completely. 

At Step 6 (run ATSPGM), the differential equations are solved. 
Each component of the equations is expanded in a Taylor series, and 
the solution point is moved forward by analytic continuation. 

ATSPGM reads the data file prepared at Step 5 and writes the 
solution results. The exact content, format, and location of the 
solution results depend on the data in ODEINP prepared at Step 1. 
Examples given below and in Chapter 3 show how this is done. 


+-+ 

I Step 1 I 

I edit ODEINP I 

+-+ 

I 

+-+ 

I Step 2 I 

I run ATOMCC.EXE I 

+-+ 

I 

+-+ 

I Step 3 I 

I compile ATSPGM I 

+-+ 

I 

I <- 

I 

+-+ 

I Step 4 I 

I I ink ATSPGM & RDCV I 

--+ 

I 

I <- 

I 

+-+ 

I Step 6 I 

I run ATSPGM.EXE I 

+-+ 


+- + 

I (RDCV.OBJ) I 

+ - + 

I 


+- + 

I Step 5 I 

I prepare data I 

+-+ 

I 


Steps for using the ATOMCC system 


2.2 Using the ATOMCC system 


In this section, we take you step-by-step through an example 
using the ATOMCC system. 
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2.2.1 Step 1 - edit ODEINP 

The input file ODEINP specifies for ATOMCC 

1 . the system of differential equations to be solved, 

2 . how the initial conditions and the interval of integration 
are communicated to ATSPGM, and 

3. the commands to control the operation of ATOMCC or to control 
the execution of ATSPGM. 

The statements in ODEINP follows FORTRAN conventions. A "C" in 
column 1 denotes a COMMENT, columns 1-5 are used for label numbers, 
column 6 is used for continuation, columns 7-72 contain statements, 
and columns 73-80 are ignored. The statements in ODEINP may be in 
either upper-case or lower-case letters. In our discussions in 
this Manual, we use upper-case letters for emphasis. (One word of 
caution:- ATOMCC does not recognize tabs.) 

Example 2-1. Simple ODEINP file. 


C FIRST PAINLEVE TRANSCENDENT 

DIFF(Y,T,2) » 6.0*Y*Y + T $ 

$ 

C READ INTEGRATION INTERVAL AND INITIAL CONDITIONS. 

READ(5,1010) START,END,Y(1),Y(2) 

1010 FORMAT(4F10.3) 

WRITER, 1020) START,END,Y(1),Y(2) 

1020 FORMAT(* SOLVE THE FIRST PAINLEVE TRANSCENDENT* / 

+ * INTERVAL: *,2F10.3 / 

+ * INITIAL CONDITIONS:*,2F10.3 /) $ 

$ 

ODEINP must contain four blocks. Each block must terminate 
with the block terminator "$" in columns 7-72. Blocks 2 and 4 are 
empty in Example 2-1 above. 

The first block contains the system of differential equations. 
These equations are processed by ATOMCC to determine the recurrence 
relations that are written into ATSPGM to generate the Taylor 
series for each component of the solution. To enter the 
differential equations, DIFF(Y,X,N) is used to denote the N-th 
derivative of Y with respect to X. The value of N may range from 1 
to 6, inclusively. The DIFF(,,) function is used to specify the 
system of ODE‘s with FORTRAN-1 ike statements using standard FORTRAN 
operators and functions. 

Rarely, ATOMCC may fail to produce the correct ATSPGM for your 
problem. In such a case, write your equations differently using 
many auxiliary variables. This will allow you to solve your 
problem; then, send a copy of the ODEINP that caused the problem to 
Y. F. Chang, Claremont McKenna College, Claremont, CA, 91711. 


BYTE LISTINGS SUPPLEMENT 267 




April 


- 11 - 

(Internal page reference for manual.doc) 


The first block can also be used to control the operation of 
ATOMCC. The most commonly used option Is for ATOMCC to write 
ATSPGM in double-precision with a "COPTION DOUBLE" card at the 
beginning of block 1 . 

Example 2-2. Double precision ATSPGM. 

COPTION DOUBLE 
C 

C FIRST PAINLEVE TRANSCENDENT 

DIFF(Y,T,2) = 6.0*Y*Y + T $ 

$ 

C READ INTEGRATION INTERVAL AND INITIAL CONDITIONS. 

READ(5, 1010 ) START,END.Y(1),Y(2) 

1010 FORMAT(4F10.3) 

WRITE(*,1020) START,END,Y(1),Y(2) 

1020 FORMAT(' SOLVE THE FIRST PAINLEVE TRANSCENDENT’ / 

+ ’ INTERVAL: *.2F10.3 / 

+ ’ INITIAL CONDITIONS:\2F10.3 /) $ 


The second block is usually empty. It is used to insert 
non-executobIe FORTRAN statements at the beginning of ATSPGM, such 
as a SUBROUTINE card, a DIMENSION card, a COMMON card, etc. 

The second, third, and fourth blocks are not processed 
syntactically by ATOMCC: they are copied directly from ODEINP into 
ATSPGM. Example 2-3 is the ATSPGM program written by ATOMCC for 
the ODEINP file shown in Example 2—1. Notice where block 3 is 
copied into an early part of ATSPGM. 

Example 2-3. ATSPGM for Example 2-1. 


c*+*+*+*+*+* 

c This program was produced by the ATOMCC translator version 7.10 
c Copyright (C) 1985, Y. F. Chang 

c #+*+*+*+*+*+*+* + * + * + * + # + * + » + # + * + * + » + * + * + » + * + * + * + * +++<1+ , + , + * +#+<t+#+#+#+ 
c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, 
c This program was written for the following inputs 
c 

C FIRST PAINLEVE TRANSCENDENT 
C DIFF(Y,T,2) = 6.0*Y*Y + T 


c no instructions in second input block 


COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN, 

+ KTRDCV,KNTSTP,KTSTIF,KXPNUM,KDIGS,KENDFG,NTERMS,NOPT 
A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR 
B /CPASS/ START.END,ORDER 
C /DPASS/ H,HNEW,XPRINT,DLTXPT 
DIMENSION TMPS( 36, 1) 

CHARACTER *6 NAMES 
EQUIVALENCE (TMPS(1. 1 ),Y( 1 )) 

DIMENSION NAMES(1), Y(36). T(2), TMPAAB(30), TMPAAA(30) 

DATA NAMES(1 )/’Y.’/ 

Y(33) =1.1 

10 FORMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; S 
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Aolution results./9H ******) 

11 FORMAT(/5X,1IHStep number,16,13H at the point.1P1E12.4/1X, 

A 9Hva!ues of ) 

12 FORMAT(IX, A6,(IX,1P4E13. 5)) 

13 FORMAT(5X,21HStepsize adjusted to ,1PE13.5) 

14 FORMAT(/5X,35HThe solution stopped normally after, I4,24H steps as 
a set by nsteps. ) 

16 FORMAT(/5X,63HThe adjustment for stepsize seems to be in a loop. P 
Alease try a /5X,22Hshorter series length. ) 

WRITE(*,10) 


c Initialize variables to default values. 


NSTEPS = 40 
H = 1.E0 
ERRLIM = 1.E- 6 
LENSER = 30 
MPRINT = 4 
NTERMS * 2 
KTRDCV * 1 

ADJSTF = 1.E-2 
MSTIFF = 0 

DLTXPT = 0.E0 


c start of third input block 


C READ INTEGRATION INTERVAL AND INITIAL CONDITIONS. 
READ(5,1010) START,END,Y(1),Y(2) 

1010 FORMAT(4F10.3) 

WRITE(*,1020) START,END,Y(1),Y(2) 

1020 FORMAT(* SOLVE THE FIRST PAINLEVE TRANSCENDENT’ / 
+ • INTERVAL: \2F10.3 / 

+ * INITIAL CONDITIONS:*,2F10.3 /) 


c end of third input block 


c More initia Iizations 


DLTXPT «= SIGN(DLTXPT, (END-START)) 

H = SIGN(H,(END-START)) 

KDIGS = 6 

XPRINT - START + DLTXPT 

KXPNUM « 35 

LENVAR = 36 

LRUN = 1 

KTSTIF «= 0 

NUMEQS - 1 

IF(LENSER.GT.(LENVAR- 6)) LENSER = LENVAR - 6 

IF(MPRINT.LT.2) GO TO 17 
WRITE(*,11) KTSTIF,START 
K = Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 


c Loop for integration steps. Inside the loop, print the desired output 


17 DO 27 KINTS-1,NSTEPS 
KOUNT - 0 
KNTSTP - KINTS 
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19 CONTINUE 

T(1) = START 
T(2) = H 
Y(2) = Y(2)*(H) 


c Preliminary series calculations 


TMPAAA(I) = 6.E0*Y(1) 

TMPAAB(I) = TMPAAA(1)*Y(1) 

Y(3) - (TMPAAB(I) + T(1))*(H*H/2.E0) 
TMPAAA(2) = 6.E0*Y(2) 

TMPAAB(2) = TMPAAA(1)*Y(2) + TMPAAA(2)*Y(1) 
Y(4) = (TMPAAB(2) + T(2))*(H*H/6.E0) 


c Loop for series calculations 


DO 23 K- 5.LENSER 
KA - K - 1 
KB as K — 2 

TMPAAA(KB) « 6.E0*Y(KB) 

TMPAAB(KB) = 0.E0 
KZ = 1 + KB 
DO 30 N=1, KB 
L = KZ - N 

TMPAAB(KB) = TMPAAB(KB) + TMPAAA(N)*Y(L) 
30 CONTINUE 

Y(K) - (TMPAAB(KB))*(H*H/(KB*KA)) 


c Test and adjust H to avoid over/under flow. 


IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 
TMP - ABS(Y(K)) 

IF(TMP.LE.1.E-35) GO TO 23 

IF(TMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 
IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 
KOUNT = KOUNT + 1 
IF(KOUNT.LT.9) GO TO 22 
WRITE(*,16) 

GO TO 28 

22 CONTINUE 

Y(2) - Y(2)/(H) 

H = H * TMP**(0.3/(1—K)) 

IF(MPRINT.GE.4) WRITE(*.13) H 
GO TO 19 

23 LRUN - 1 


c Calculate radius of convergence and take optimum step. 


CALL RDCV(TMPS.LENVAR,NUMEQS.NAMES) 
24 CALL RSET(TMPS,LENVAR.NUMEQS.NAMES) 


c no instructions in fourth input block 


25 GO TO (26,28,24), KENDFG 

26 H = SIGN(RADIUS.H) 

START = START + HNEW 

IF(MPRINT.LT.4) GO TO 27 
WRITE(*.11) KNTSTP, START 
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K = Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 

27 CONTINUE 
WRITE(*,14) NSTEPS 

28 CONTINUE 

29 STOP 
END 

The third block is usually used to specify the interval of 
integration and the initial conditions by reading them from a data 
file prepared at Step 5. This is the file DATA opened in block 3. 
The interval of integration is from START to END. END is allowed 
to be less than START for integration in a negative direction. The 
initial values (at START) of a dependent variable named y and its 
derivatives are assigned to the array Y as follows:— 

Y(1) denotes y at START, 

Y(2) denotes y* at START, 

Y(3) denotes y'* at START, etc. 

Thus in Example 2-1, two initial conditions Y(1) for y(0) and Y(2) 
for y*(0) are entered for the second order differential equation. 

Any valid FORTRAN statement may be included in block 3 to be 
copied into ATSPGM, as shown in Example 2-1 by the WRITE statement 
to echo the input. The third block may also be used to change the 
default values of method-controlling variables. You can see in 
Example 2-3 that many variables are initialized immediately before 
block 3. The meaning of these variables is described in Chapter 3. 

The fourth block is usually empty. It may be used to insert 
statements into ATSPGM at the end of each integration step. 

This concludes the discussion of how to prepare the input 
file. More information about the use of specific features can be 
found in Chapter 3. 


2.2.2 Step 2 - Run ATOMCC 

The appropriate command to execute the ATOMCC compiler is 
simply [ATOMCC]. The ATOMCC translator uses two files:- ODEINP for 
the equation statements and initial conditions, and ATSPGM for the 
output object program. (The names ODEINP and ATSPGM are fixed 
within ATOMCC.) The messages produced by ATOMCC are placed on your 
terminal. To have the messages written onto a disc file (say MSG), 
use the command [ATOMCC > MSG], 
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Example 2-4. Translator messages for Example 2-1. 


ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang. 


Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved. 

FIRST PAINLEVE TRANSCENDENT 

DIFF(Y,T,2) = 6.0*Y*Y + T $ 
equation 1 is in position 1 
$ 

READ INTEGRATION INTERVAL AND INITIAL CONDITIONS. 

READ(5,1010) START,END.Y(1),Y(2) 

1010 F0RMAT(4F10.3) 

WRITE(*,1020) START,END,Y(1).Y(2) 

1020 FORMAT(’ SOLVE THE FIRST PAINLEVE TRANSCENDENT' / 

+ ' INTERVAL: '.2F10.3 / 

+ ' INITIAL CONDITIONS:',2F10.3 /) $ 

$ 

ATOMCC completed 
Stop - Program terminated. 


2.2.3 Step 3 and 4 - Compile and link ATSPGM 

As you get comfortable with the ATOMCC system, you will rarely 
inspect ATSPGM, unless either an error occurs, or you choose to 
edit ATSPGM by hand. 

ATSPGM. written by ATOMCC. is just like any other FORTRAN 
program; you may edit it to suit your needs. Whether edited or 
not, ATSPGM is ready to be compiled and linked with the necessary 
subroutines from the ATOMCC library (RDCV). 

The appropriate commands to compile and link ATSPGM ore:- 

- B:F0R1 ATSPGM. ; 

- B:PAS2 

- B:LINK ATSPGM+RDCV,.NUL,B: 


2.2.4 Step 5 - Prepare the data 

At Step 1. when you prepared ODEINP for ATOMCC. you may have 
included some READ statements in block 3 to communicate the 
interval of integration and the initial conditions to ATSPGM. 

Before you run ATSPGM, the data file to be read by those statements 
must be prepared with the appropriate file name given in your OPEN 
statement. 
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Example 2-5. Data file for Example 2-1. 

0.000 1.100 1.000 0.000 

If you know that you will be solving a simple problem only 
once, Step 5 can be eliminated by stating the values of START, END, 
and the initial conditions with FORTRAN assignment statements in 
block 3 as shown below. 

Example 2-6. Assignment statements in block 3. 


C First Painleve transcendent 

DIFF(Y,T,2) = 6.0*Y*Y + T $ 

$ 

C Assign integration interval and initial conditions. 
START =0.0 
END = 1.1 
Y(1) = 1.0 
Y(2) = 0.0 

WRITE(*.1020) START,END,Y(1),Y(2) 

1020 FORMAT(* Solve the first Painleve transcendent* / 
+ * IntervaI: *,2F10.3 / 

+ * Initial conditions:*,2F10.3 /) $ 

$ 


2.2.5 Step 6 - Run ATSPGM 

At step 6 , you are ready to run ATSPGM; the command is simply 
[ATSPGM]. ATSPGM writes its output to your terminal, for solution 
output on a disc file (say PRTOUT) use [ATSPGM > PRTOUT]. 

Example 2-7. Solution Output for Example 2-1. 


ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; Solution results. 
* * * * * * 

SOLVE THE FIRST PAINLEVE TRANSCENDENT 
INTERVAL: .000 1.100 

INITIAL CONDITIONS: 1.000 .000 

Step number 0 ot the point .0000E+00 
values of 

Y . 1.00000E+00 .00000E+00 

Step number 1 at the point 7.1000E-01 
values of 

Y . 4.04877E+00 1.62701E+01 
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Step number 2 at the point 1.0100E+00 
values of 

Y . 2.58324E+01 2.62656E+02 

Step number 3 at the point 1.1000E+00 
values of 

Y . 8.77693E+01 1.64459E+03 

Stop - Program terminated. 


2.3 Output at equally spaced points 


You should be able to use ATOMCC to solve routine problems. 

The points at which ATSPGM computes the solutions are determined by 
the actual integration steps taken, which are not uniform in size. 
This Section shows you how to force ATSPGM to print the solutions 
at equally spaced points. 

The output from ATSPGM is controlled by two variables, MPRINT 
(amount of print), and DLTXPT (print interval). To produce output 
at equally spaced points, assign MPRINT=2 to turn off the print at 
the actual integration steps, and assign DLTXPT*DELTA, where DELTA 
is your desired print interval. 

Example 2-8. Equally spaced output points. 


c First Painleve transcendent 

DIFF(Y,T,2) = 6.0*Y*Y + T $ 

$ 

c Assign integration interval and initial conditions. 
MPRINT = 2 
DLTXPT * 0.2 
START =0.0 
END = 1.1 
Y(1) = 1.0 
Y(2) = 0.0 

WRITER, 1020) START,END,Y(1),Y(2) 

1020 FORMAT(* Solve the first Painleve transcendent* / 
+ * Interval: *.2F10.3 / 

+ * Initial conditions:*,2F10.3 /) $ 

$ 


2.3.1 ZEROT - Stopping at roots of variables 

It is often of interest to locate points at which a component 
of the solution has a root or assumes some specified value. The 
subroutine ZEROT automatically solve such problems. DZEROT is the 
double-precision version. 
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The form of the CALL is 

CALL ZEROT(NUMBER,Y,ROOT,KEY,TMPS,LENVAR,NUMEQS) 

where 

NUMBER is the index of the Y series term whose root is sought, 

Y is the variable whose root is desired, 

ROOT is the value Y is to assume (= 0 for a root), 

KEY is 1 if Y is a dependent variable, or 

0 if Y is not a dependent variable. 

The arguements TMPS, LENVAR, and NUMEQS must be exactly as 
written above. 

Example 3-16. Rootfinding with ZEROT. 


DIFF(Y,T,2) = 6*Y*Y + T $ 

$ 


START =0.0 
END =1.15 
ROOT =20.0 



$ 

CALL ZEROT(1,Y,ROOT,1) 


When the variable whose root is being sought is not a dependent 
variable, KEY is set to 0. 

CALL ZER0T(2,VARY,0.0,0) 

IF(LRUN.NE.0) GO TO 25 
TEMP = START + HNEW 

WRITE(7,1010) KINTS,TEMP,VARY(1),VARY(2) 

1010 FORMAT(15,3F10.4) 

GO TO 25 $ 

In these examples, it is not necessary for one to print the 
information as shown in the second case. The ATSPGM program does 
stop and restart the solution automatically at the exact root and 
the output is controlled by MPRINT. 

The index NUMBER can be set at any positive (non-zero) integer 
value; however, obviously when NUMBER is very large the accuracy of 
the root wiI I suffer. 


2.3.2 MSTIFF=20,21,22 - Stiff problems. 

This version of ATOMCC contains a double-precision algorithm to 
solve stiff problems. To use It, one can either set MSTIFF=20, or 
21, or 22. Other parameters that should be controlled are H, 

ADJSTF, and NSTEPS. It is also desirable to set MPRINT to 7, at 
least initially, for observing the progress of the solution. If it 
should be evident that the problem is not really stiff, then it is 
most advisable to solve it as a normal problem. 
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MSTIFF-20 is the more conservative of the three algorithms. In 
this case, LENSER is set to be 15. The default value for ADJSTF, 
the error-controI Iing parameter, is a rather large 1.E-2. The user 
should run the stiff solution at least one more time with a 
somewhat smaller ADJSTF, say 1.E-3, to check on its validity. 


When MSTIFF-21. LENSER is set to only 10. So, this option 
should be used only if the user is absolutely certain that the 
problem under study is very stiff. The solution of stiff problems 
under this option is considerably faster than that for MSTIFF-20. 

MSTIFF-22 is identical to MSTIFF-20 except for the fact that 
there is no attempt to identify steady-state solutions. 


As mentioned above, the stiff 
precision. It is simply not cost 
using single-precision. There is 
problems. All such problems must 


a Igorithm 
effective 
one other 
be stated 


is written in double- 
to solve such problems 
restriction on stiff 
as first-degree ODE’s. 
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Chapter 3 
How to Use - 


This Chapter is written for users who already have solved 
several problems using the ATOMCC system. It assumes familiarity 
with FORTRAN programming, with Chapter 2, and with the numerical 
solution of ODE’s. This Chapter is the heart of this User Manual. 
It attempts to show how to use each of the features available from 
ATOMCC and from ATSPGM. It is organized for reference, not for 
sequential reading. Consequently, some information found in other 
parts of this Manual are repeated here. 


3.1 Solving your problem 


The tasks which must be accomplished In order to run the ATOMCC 
system on your computer were discussed in Section 2.2. They are:- 

Edlt ODEINP (containing ODE’s) 

Run ATOMCC.EXE (execute ATOMCC translator) 

(This creates ATSPGM, the object FORTRAN program, 
which is treated like any FORTRAN program. 

ATSPGM may be edited.) 


Compile ATSPGM. 

(This creates ATSPGM.OBJ, the object module.) 


Link 


ATSPGM.OBJ, with library 
(RDCV.OBJ 
DRDCV.OBJ 
CRDCV.OBJ 
CDRDCV.OBJ 
(This creates ATSPGM.EXE, 


opt ions 

for single precision 
for double precision 
for complex, and 
for complex double) 
the execution module.) 


Edit DATA input-file if any is used. 


Run ATSPGM.EXE 


3.1.1 Translator file, ODEINP 

The ODEINP file contains the ODE’s to be solved and information 
specifying how the initial conditions and the integration interval 
are determined in ATSPGM. It may contain commands to control 
(a)the operation of the ATOMCC translator, (b)the execution of the 
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solution, and (c)the desired format of the output. The names 
ODEINP and ATSPGM are fixed within ATOMCC; you must have these 
files on your disc when you execute ATOMCC. 

The data in ODEINP follows FORTRAN conventions. Columns 1-5 
are used for line numbers, column 6 Is used for continuation 
characters, columns 7-72 contain statements, and columns 73-80 are 
ignored. As in FORTRAN, all blanks are ignored. A *C* in column 1 
denotes a comment which is copied directly into the ATSPGM file. 

The statements in ODEINP can be either upper-case or lower-case 
letters. We use upper-case in this manual for emphasis. (A word 
of caution, the tab character is not recognized by ATOMCC.) 

The ODEINP file contains four blocks. Each block ends with the 
block terminator symbol ’$’ in columns 7-72. (A comment card must 
not contain a block terminator *$'.) Sections 3.2-3.4 discuss each 
of the blocks in detail. Here is an example of an input file which 
illustrates several of the features which will be discussed in 
Sections 3.2-3.5. 

Example 3-1. ODEINP file. 


C Block 1 
C 

C System with parameter. 

C 

DIFF(X,T,2) * - ALPHA*X*R 
DIFF(Y,T,2) = - ALPHA*Y*R 
R = (x*X + Y*Y)**(-1.5) 

ALPHA =0.65 $ 

c 

c Block 2 
c 

CHARACTER+80 LINE $ 

c 

c Block 3 
c 

c Read:- heading line, print code, maximum number of integration 
c steps, 

c Echo the above. 

c Read:- heading line, integration interval, print interval, 
c parameter in equations, initial conditions, 

c Echo the above, 
c 

0PEN(5,FILE= , DATA’) 

OPEN(7,FILE=•PLOTS’,STATUS-’NEW *) 

READ(5,1010) LINE,MPRINT.NSTEPS 
1010 FORMAT(A80/2I10) 

WRITER, 1010) LINE.MPRINT,NSTEPS 

READ(5,1020) LINE,START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) 
1020 FORMAT(A80/8F10.3) 

WRITE(*,1020) LINE,START,END,DLTXPT,ALPHA.X(1),X(2),Y(1),Y(2) 
c Assignment statements for the error control parameter 
ERRLIM = 1.0E-04 $ 
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c 

c Block 4 
c 

c Produce file of data for plotting, 
c 


IF(KENDFG.EQ.3) WRITE(7,1030) 
1030 FORMAT(15,1P5E14.5) $ 


KINTS,XPRINT,X(1),X(2),Y(1),Y(2) 


If you have a simple problem which will be solved only once, 
the contents of the 'DATA* file may be entered directly as data 
into block 3. However, the compilation and linking of the ATSPGM 
file takes an appreciable amount of time and therefore should be 
avoided on problems that is solved more than once. 


There are two ways to solve a given problem containing 
functions. Either they can be placed as FORTRAN statements in 
ODEINP to be copied directly into ATSPGM, or they can be inserted 
by editing ATSPGM. The choice depends on your personal style; the 
authors prefer to work with ODEINP, because it is short. 

Therefore, it is easy to find the correct place to make changes. 
The cost of re-running the ATOMCC translator is well worth the 
convenience, because ATOMCC is very fast. 


3.1.2 Translator file, the terminal 

The translator messages contains the information which the 
ATOMCC expects you to inspect. It includes an echo of the input 
file and any error messages. The Appendix contains a list of the 
error messages which may be produced. The messages will appear on 
your terminal. 

Example 3-2. Translator messages for Example 3-1. 


ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang. 
Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved. 


c Block 1 

c System with parameter. 

DIFF(X,T,2) * - ALPHA*X*R 
DIFF(Y,T,2) = - ALPHA*Y*R 
R = (X*X + Y*Y)**(-1.5) 
ALPHA = 0.65 $ 

equation 3 is in position 1 

equation 4 is in position 2 

equation 1 is in position 3 

equation 2 is in position 4 

c Block 2 

CHARACTERS© LINE $ 
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c Block 3 

c Read:- heading line, print code, maximum number of integration 
c steps, 

c Echo the above. 

c Read:- heading line, Integration interval, print interval, 
c parameter in equations, Initial conditions, 

c Echo the above. 

0PEN(5.FILE-’DATA’) 

OPEN(7,FILE= ’ PLOTS *,STATUS-’NEW *) 

READ(5,1010) LINE,MPRINT,NSTEPS 
1010 FORMAT(A80/2I10) 

WRITE(*,1010) LINE,MPRINT,NSTEPS 

READ(5,1020) LINE,START.END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) 

1020 FORMAT(A80/8F10.3) 

WRITE(*,1020) LINE.START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) 
c Assignment statements for the error control parameter 
ERRLIM = 1.0E-04 $ 

c Block 4 

c Produce file of data for plotting. 

IF(KENDFG.EQ.3) WRITE(7.1030)KINTS.XPRINT,X(31),X(32).Y(31),Y(32) 
1030 F0RMAT(I5,1P5E14.5) $ 

ATOMCC completed 
Stop - Program terminated. 


3.1.3 Translator file, ATSPGM 

The ATSPGM file contains the FORTRAN object program written by 
ATOMCC to solve the system of differential equations using long 
Taylor series. ATOMCC uses the variable names given in ODEINP, so 
that ATSPGM appears to have been custom written for the specific 
problem. Usually you do not need to inspect ATSPGM, but sometimes 
you may find it necessary to edit it like you would edit any other 
FORTRAN program to achieve some particular result. Section 3.6 
contains an example for which editing of ATSPGM is necessary. 

Example 3-3. ATSPGM for Example 3-1. 


c*+*+*+*+*+* 

c This program was produced by the ATOMCC translator version 7.10 
c Copyright (C) 1985, Y. F. Chang 

c*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ 
c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, 
c This program was written for the following inputs 
c 

C BLOCK 1 

C SYSTEM WITH PARAMETER. 

C DIFF(X,T,2) = - ALPHA*X*R 

C DIFF(Y,T,2) = - ALPHA*Y*R 

C R = (X*X + Y*Y)**(-1.5) 

C ALPHA =0.65 

c- 
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c start of second input block 


c Block 2 
c 

CHARACTER*80 LINE 


c end of second input block 


COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN, 

+ KTRDCV,KNTSTP,KTSTIF,KXPNUM,KDIGS,KENDFG,NTERMS,NOPT 
A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR 
B /CPASS/ START,END,ORDER 
C /DPASS/ H,HNEW,XPRINT,DLTXPT 
DIMENSION TMPS( 36, 2) 

CHARACTER*6 NAMES 

EQUIVALENCE (TMPS(1,1),X(1)),(TMPS(1.2),Y(1)) 

DIMENSION NAMES(2), T(2), Y(36), X(36), R(30). TMPAAH(30), 

A TMPAAG(30), TMPAAF(30), TMPAAE(30), TMPAAD(30), TMPAAC(30), 

B TMPAAB(30) 

DATA NAMES(1 )/*X.7 

DATA NAMES(2)/* Y.•/ 

X(33) =1.1 
Y(33) = 2.1 

10 FORMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; S 

Aolution results./9H ******) 

11 FORMAT(/5X,11HStep number,16,13H at the point,1P1E12.4/1X, 

A 9Hvalues of ) 

12 FORMAT(IX, A6,(IX,1P4E13. 5)) 

13 FORMAT(5X,21HStepsize adjusted to .1PE13.5) 

14 F0RMAT(/5X,35HThe solution stopped normally after, I4.24H steps as 
a set by nsteps. ) 

16 F0RMAT(/5X,63HThe adjustment for stepsize seems to be in a loop. P 
Alease try a /5X,22Hshorter series length. ) 

WRITE(*,10) 


c Initialize variables to default values. 


NSTEPS = 40 
H = 1.E0 
ERRLIM = 1.E- 6 
LENSER = 30 
MPRINT = 4 
NTERMS = 2 
KTRDCV = 2 

ADJSTF « 1.E-2 
MSTIFF = 0 

DLTXPT = 0.E0 


c constant expressions 


ALPHA = 6.5E-1 


c start of third input block 


c Block 3 
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c Read:- heading line, print code, maximum number of integration 
c steps, 

c Echo the above. 

c Read:- heading line, integration interval, print interval, 
c parameter in equations, initial conditions, 

c Echo the above, 
c 

OPEN(5,FILE*’DATA’) 

0PEN(7,FILE-’PLOTS *,STATUS®* NEW 1 ) 

READ(5,1010) LINE,MPRINT,NSTEPS 
1010 FORMAT(A80/2I10) 

WRITE(*,1010) LINE.MPRINT.NSTEPS 

READ(5,1020) LINE,START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) 

1020 FORMAT(A80/8F10.3) 

WRITE(*,1020) LINE,START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) 
c Assignment statements for the error control parameter 
ERRLIM = 1.0E-04 
c- 

c end of third input block 

c- 

TMPAAA = -1.5E0 
c- 

c constant expressions 
c- 

c More initializations 
c- 

DLTXPT = SIGN(DLTXPT,(END-START)) 

H = SIGN(H,(END-START)) 

KDIGS = 6 

XPRINT » START + DLTXPT 

KXPNUM = 35 

LENVAR = 36 

LRUN - 1 

KTSTIF - 0 

NUMEQS - 2 

IF(LENSER.GT.(LENVAR- 6)) LENSER « LENVAR - 6 

IF(MPRINT.LT.2) GO TO 17 
WRITE(*,11) KTSTIF,START 
K = X(33) 

WRITE(*,12) NAMES(K),X(1), X(2) 

K = Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 

c- 

c Loop for integration steps. Inside the loop, print the desired output 


17 DO 27 KINTS=1,NSTEPS 
KOUNT = 0 
KNTSTP = KINTS 
19 CONTINUE 

T(1) = START 
T(2) = H 



c Preliminary series calculations 
c- 

TMPAAB(I) = X(1)*X(1) 
TMPAAC(1) = Y(1)*Y(1) 
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TMPAAE(1) = AIPHA*X(1) 

TMPAAG(1) = ALPHA*Y(1) 

TMPAAD(l) = TMPAA8(1) + TMPAAC(l) 

R(1) = TMPAAO(1) ** TMPAAA 
TMPAAF(1) = TMPAAE(1)*R(1) 

TMPAAH(I) = TMPAAG(1)*R(1) 

X(3) = (-TMPAAF(1))*(H*H/2.E0) 

Y(3) = (-TMPAAH(1))*(H*H/2.E0) 

TMPAAB(2) - X(1)*X(2) + X(2)*X(1) 

TMPAAC(2j - Y(1)*Y(2) + Y(2)*Y(1) 

TMPAAE(2) = ALPHA*X(2) 

TMPAAG( 2) = ALPHA*Y(2) 

TMPAAO(2) » TMPAAB(2) + TMPAAC(2) 

R(2) = TMPAAA*R(1)*TMPAAD(2)/TMPAAD(1) 
TMPAAF(2) = TMPAAE(1)*R(2) + TMPAAE(2)*R(1) 
TMPAAH(2) = TMPAAG(1)*R(2) + TMPAAG(2)*R(1) 
X(4) = (-TMPAAF(2))*(H*H/6.E0) 

Y(4) = (-TMPAAH(2))*(H*H/6.E0) 


c Loop for series calculations 


DO 23 K= 5.LENSER 

KA = K - 1 

KB = K - 2 

KC = K - 3 

TMPAAB(KB) - 0.E0 
TMPAAC (KB) «= 0.E0 
KZ = 1 + KB 
DO 30 N-1, KB 
L = KZ - N 

TMPAAB(KB) « TMPAAB(KB) + X(N)*X(L) 
TMPAAC(KB) = TMPAAC(KB) + Y(N)*Y(L) 

30 CONTINUE 

TMPAAE(KB) = ALPHA*X(KB) 

TMPAAG(KB) = ALPHA*Y(KB) 

TMPAAD(KB) = TMPAAB(KB) + TMPAAC(KB) 

R(KB) * R(1)*TMPAAD(KC+1)*(KC)*TMPAAA 
KY = 2 + KC 
DO 31 N-2, KC 
L = KY - N 
AL - (L - 1) 

31 R(KB) « R(KB) + R(N)*TMPAAD(L)*AL 
A *TMPAAA - TMPAAD(N)*R(L)*AL 

R(KB) = R(KB) /(KC)/TMPAAD(1) 

TMPAAF(KB) « 0.E0 
TMPAAH(KB) = 0.E0 
KZ = 1 + KB 
DO 32 N-1, KB 
L = KZ - N 

TMPAAF(KB) = TMPAAF(KB) + TMPAAE(N)*R(L) 
TMPAAH(KB) = TMPAAH(KB) + TMPAAG(N)*R(L) 

32 CONTINUE 

X(K) = (-TMPAAF(KB))*(H*H/(KB*KA)) 

Y(K) - (-TMPAAH(KB))*(H*H/(KB*KA)) 


c Test and adjust H to ovoid over/under flow. 


IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 
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TMP - ABS(X(K)) 

IF(TMP.LE.1.E-35) GO TO 23 

IF(tMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 
IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 
KOUNT « KOUNT + 1 
IF(KOUNT.LT.9) GO TO 22 
WRITE(*,16) 

GO TO 28 

22 CONTINUE 

?ili: mj 

H * H * TMP**(0.3/(1-K)) 

IF(MPRINT.GE.4) WRITE(*,13) H 
GO TO 19 

23 LRUN = 1 


c Calculate radius of convergence and take optimum step. 


CALL RDCV(TMPS,LENVAR,NUMEQS,NAMES) 
24 CALL RSET(TMPS,LENVAR,NUMEQS,NAMES) 


c start of fourth input block 


c Block 4 
c 

c Produce file of data for plotting, 
c 

IF(KENDFG.EQ.3) WRITE(7,1030)KINTS,XPRINT,X(31),X(32),Y(31),Y(32) 
1030 FORMAT(15,1P5E14.5) 


c end of fourth input block 


25 GO TO (26,28,24), KENDFG 

26 H - SIGN(RADIUS.H) 

START * START + HNEW 

IF(MPRINT.LT.4) GO TO 27 
WRITEf*,11) KNTSTP, START 
K = X(33) 

WRITE(*,12) NAMES(K),X(1), X(2) 
K = Y(33) 

WRITE(*,12) NAMES(K),Y(1), Y(2) 

27 CONTINUE 
WRITE(*,14) NSTEPS 

28 CONTINUE 

29 STOP 
END 


3.1.4 DATA input file 

For most problems solved using the ATOMCC system, you should 
communicate the initial conditions, the integration interval, the 
coefficients in the differential equations, and the ATOMCC control 
parameters by reading them from a DATA input file. 
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Example 3-4. DATA input file for Example 3-1. 


MPRINT NSTEPS for example 3-1 

4 80 

START END DLTXPT ALPHA X(1) X(2) Y(1) Y(2) 

1.0 10.0 0.25 0.58 -1.0 0.0 0.0 4.3 


3.1.5 Solution file 

ATSPGM writes all of Its messages and answers to your 
terminal. The format of the solution depends on the ATOMCC control 
parameters (see Section 3.4). If you should wish to have the 
solution written onto a disc file, you can use the execution 
statement (ATSPGM > PRTOUT). Then, all messages and answers will 
be written to the solution file PRTOUT. The solution file can also 
contain Informa- tion written by user supplied WRITE(*,xxx) 
statements. A portion of the solution file is given below. 

Example 3-5. Solution file for Example 3-1. 


ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; Solution results. 
****** 

MPRINT NSTEPS for example 3-1 

4 80 

START END DLTXPT ALPHA X(1) X(2) Y(l) Y(2) 

1.000 10.000 .250 .580 -1.000 .000 .000 4.300 

Step number 0 at the point 1.0000E+00 
values of 

X. -1.00000E+00 .00000E+00 

Y .00000E+00 4.30000E+00 

Step number 1 at the point 1.1430E+00 

values of 

X. -9.94536E-01 7.08452E-02 

Y . 6.13850E-01 4.27990E+00 

Step number 2 at the point 1.2500E+00 
values of 

X. -9.85268E-01 9.92472E-02 

Y . 1.07052E+00 4.25646E+00 

Step number 2 at the point 1.3400E+00 
values of 

X. -9.75709E-01 1.11976E-01 

Y . 1.45285E+00 4.24032E+00 

Step number 3 at the point 1.5000E+00 
values of 

X. -9.56779E-01 1.23037E-01 

Y . 2.12958E+00 4.22039E+00 
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voiuel*of numb * r 3 ot th ® polnt 

*. -9.39208E-01 1.27496E-01 

Y . 2.71959E+00 4.20915E+00 

voluerof nUmt><!,r 4 0t the P °' nt 1 - 75 00E+00 

5. -9.25064E-01 1.29523E-01 

Y . 3.18223E+00 4.20277E+00 

vaIues*of nUmber 4 0t th * P °' nt 2 - 000( *+00 
5. -8.92333E-01 1.31982E-01 

Y . 4.23159E+00 4.19295E+00 

values 6 ©/™"’ 6 ^ 4 0t th ® P ° int 2.1300E+00 

*. -8.75128E-01 1.32677E-01 

Y . 4.77644E+00 4.18942E+00 

3.1.6 User files 

stotemertts°to e produce'outDut*?n*o y f^ °7 n ? utput fll * s usln 9 WRITE 

aaru~ ,,Jr: '“ s • '»• jas- g~ u 


Example 3-6. User file for plotti 


ng. 


2 

3 

4 

4 

5 

5 

6 
6 
6 
6 
6 
7 


1.25000E+00 
1.50000E+00 
1.75000E+00 
2.00000E+00 
2.25000E+00 
2.50000E+00 
2.75000E+00 
3.00000E+00 
3.25000E+00 
3.50000E+00 
3.75000E+00 
4.00000E+00 


-9.85268E-01 
-9.56779E-01 
-9.25064E-01 
-8.92333E-01 
-8.59178E-01 
-8.25810E-01 
-7.92324E-01 
-7.58765E-01 
-7.25160E-01 
-6.91524E-01 
-6.57866E-01 
-6.24192E-01 


9.92472E-02 
1.23037E-01 
1.29523E-01 
1.31982E-01 
1.33133E-01 
1.33750E-01 
1.34112E-01 
1.34340E-01 
1.34490E-01 
1.34594E-01 
1.34667E-01 
1.34720E-01 


1.07052E+00 
2.12958E+00 
3.18223E+00 
4.23159E+00 
5.27900E+00 
6.32514E+00 
7.37039E+00 
8.41497E+00 
9.45904E+00 
1.05027E+01 
1.15461E+01 
1.25891E+01 


4.25646E+00 
4.22039E+00 
4.20277E+00 
4.19295E+00 
4.18678E+00 
4.18258E+00 
4.17953E+00 
4.17723E+00 
4.17542E+00 
4.17398E+00 
4.17279E+00 
4.17179E+00 


3.2 Using bIock 1 
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The first block may also be used for ATOMCC options to control 
the operation of the translator. This Is done by placing a COPTION 
card at the beginning of ODEINP. Multiple translator options may 
be specified on the same line, i.e. COPTION DOUBLE, LENVAR=40. 
Multiple COPTION cards are also allowed, but they must precede all 
other cards. 


3.2.1 Format for the system of equations 

For the differential equations, DIFF(Y,X,N) is used to denote 
the n-th derivative of the dependent variable y with respect to the 
independent variable x. The value of the variable N may range from 
1 to 6, inclusively. The DIFF(X,Y,N) function is used to specify 
ODE’s just as with other standard FORTRAN operators and functions. 
All functions supported by ATOMCC are listed in Section 4.2. The 
statements in ODEINP can be either upper- or lower-case letters. 


We use upper-case in this manual for emphasis. 

The input to ATOMCC follows FORTRAN conventions. Comment cards 
contain a *C’ In column 1. The entire comment card is reproduced in 
ATSPGM. A comment card must not contain a block terminator ’$*. 
Columns 1-5 are used to enter line numbers. Column 6 is used for 
continuation; there is a limit of 19 continuation lines in 
FORTRAN. Columns 7-72, where the block terminator ’$’ must appear, 
contain the statements of the equations. Columns 73-80 are 
ignored. As In FORTRAN, blanks are not significant. (A word of 
caution, the tab character is not recognized by ATOMCC.) 

The equations In block 1 must be of the form 

DIFF(X.Y.N) - expression, 
variable - DIFF(X.Y.N), 
or variable ■ expression. 

An expression may contain operations on variables and DIFF(,,) 
functions. The highest order derivative of each dependent variable 
must be given explicitly by an equation of the form DIFF(,,) « 
expression, but DIFF(,,) functions of lower order may appear in 
expressions on the right hand side. A system of differential 
equations may be specified with more than one independent 
variable. But, each independent variable will have the same value 
as the solution is computed. Independent variables are implicitly 
defined by the DIFF(,,) function for that independent variable, so 
explicitly defining one in an assignment statement will cause an 
error message to be printed which indicates that the independent 
variable in question has already been defined. 

Incidentally, ATOMCC transforms all constant Integer powers of 
a variable up to 4 into multiplications. This is done in order to 
avoid the problems raised by the initial value of that variable 
being equal to zero. For integer powers greater than 4, the user 
is responsible to see that a I’Hopital situation does not arise. 

Except for integer powers, constant coefficients which appear 
in ODE’s are converted to real numbers by ATOMCC, so that it does 
not matter whether three Is written as 3, 3.0, 3.E0, or 3.D0. 
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3.2.2 Parameters In the equations 

Example 3-1 shows a system Involving parameters. It is often 
interesting to explore the dependence of the solution on parameters 
which appear in the differential equation. The ATOMCC system is 
especially well suited to this problem, because ATSPGM can be 
generated only once and then executed repeatedly for different 
values of the parameters. 

You may enter the parameters as constants directly Into the 
statement of the equations. In that case, ATOMCC writes those 
constants directly into ATSPGM; this approach does not allow easy 
modification of the parameters. Note that all constants (except 
integer powers) are converted to real numbers by ATOMCC. so that it 
does not matter whether three is written os 3, 3.0, 3.E0, or 3.00. 

If you wish to change the values of the parameters, moke each 
parameter in the equation to appear os a variable as shown in 
Example 3-1. Note that the variable parameters must be assigned 
dummy values in block 1, even though the actual values may be 
specified at solution time by statements In block 3. 

If the values of the parameters ore to be supplied at solution 
time by reading from a data file or from a terminal, it moy be 
convenient to solve the problem repeatedly os shown by Example 3—14- 
In Section 3.4.2. 


3.2.3 COPTION DOUBLE - Double-precision ATSPGM 

. T J"'? SS You specify differently, the ATSPGM program generated by 
ATOMCC is written in single-precision. A COPTION DOUBLE card, as 
the first card In ODEINP, signals ATOMCC to write ATSPGM in 
double-precision. No other changes should be made in block 1. In 
particular, if the ODE's have library functions such as SIN, EXP 
etc.. ATOMCC automatically inserts DSIN, DEXP, etc. into ATSPGm’ 
You should not make those substitutions yourself. 

Example 3—7. Double precision object program. 


COPTION DOUBLE 

DIFF(Y,T,2) = 6*Y*Y + T $ 

$ 

C Read initial conditions and integration interval 
0PEN(5,FILE=’DATA’) 

READ(5,1010) START.END,Y(1),Y(2) 

1010 FORMAT(4F10.3) 

WRITE(*.1020) START,END.Y(1),Y(2) 

1020 FORMAT( Solve the first Painleve transcendent 
+ ’ Interval: •.2F10.3 / 

+ * Initial conditions:’,2F10.3 /) $ 

$ 


/ 
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In a double-precision ATSPGM program:- 

real variables are declared as double precision; 

double-precision FORTRAN functions (i.e. DLOG) are generated 
in ATSPGM; (The user must still use single-precision functions 
?n the first block.) 

call statements in ATSPGM reference the double-precision 
ATOMCC library routines DRSET, DSTEP, and DRDCV; 

- FORMAT statements use D-format for real variables; 
constants are generated in double-precision form. 

Some changes may be required in blocks 2, 3, and 4. ATOMCC 
copies them directly into ATSPGM, so you are responsible for any 
changes such as declarations or format modifications. 

Be sure to link ATSPGM.OBJ with the double-precision ATOMCC 
subroutine library, DRDCV.OBJ. Incidentally, stiff problems are 
solved only in double-precision. 


3.2.4 COPTION COMPLX - Complex ATSPGM 

Including a COPTION COMPLX card as the first card In ODEINP 
signals ATOMCC to write a single-precision complex ATSPGM. 

Example 3-8. Complex object program. 


COPTION COMPLX 

DIFF(Y,T,2) * 6*Y*Y + T $ 

$ 

0PEN(5,FILE*’DATA’) 

READ(5,1010) MPRINT,NSTEPS,KPTS 
1010 FORMAT(315) 

WRITE(*,1010) MPRINT,NSTEPS,KPTS 
C 

C Read initial conditions 

READ(5,1020) Y(1),Y(2) 

1020 FORMAT(8F10.3) 

WRITER,1020) Y( 1) ,Y(2) 

C 

C Read piecewise linear path 

READ(5,1020) (POINTS(I),1=1,KPTS) 

WRITE(*.1020) (POINTS(I) , 1*1.KPTS) $ 

$ 

No other changes should be made in block 1. If the ODE’s have 
library functions like SIN, EXP, etc., ATOMCC automatically inserts 
CSIN, CEXP, etc. into ATSPGM. You should not write any complex 
functions yourself. 

Some changes may be required in blocks 2, 3, and 4. ATOMCC 
copies them directly into ATSPGM, so you are responsible for any 
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lnden!nH!n* h °! <| ec 1 '<>"s or format modifications. The 

c b hin\e% r ??om a ^a£e"!S"?^^^|i e 8 & •Jv"-'"* 

zssfcx.'jr. iu.;; s r.*:=:;: i *’ 3 

The other important change required for a comoIey AT qpru i* + k 
manner n which rtri + k ^ .. . u com P«©x AibrGM is the 

:r,a5!s,s^ sr.s ssrj-,i« 

is best to n keep'MPR?N?-4° f C0 " P ': X P '° ne f ° r It 

10 Kee P mkkint=4. Higher va ues of MPRINT nniu i«„j„ l. 

ever more confusing amounts of print outputs * 

3.2.5 COPTION DOUBLE. COMPLX - Double-complex ATSPGM 

Example 3-9. Double complex object program. 

COPTION DOUBLE,COMPLX 

DIFF(Y,T,2) - 6*Y*Y + T $ 

0PEN(5,FILE«’DATA’) 

. 0,0 raSl?®’ ^'“T.NSTEPS.KPTS 
WRITE(*.1010) MPRINT.NSTEPS.KPTS 

w 

C Read initial conditions 

READ(5,1020) Y(1),Y(2) 

1020 FORMAT(8F10.3) ' 

WRITE(*.1020) Y(1).Y(2) 

V 

C Read piecewise linear path 

READ(5,1020) (POINTS(I).I-I.KPTSl 
WRITE(*.1020) (POINTS(I),1=1,KPTS) $ 

sseIJ’';:,:’’ i?c par i;s5^ r - " 

of atspom R-g^u S4r 0 por "“ 

Example 3-10. ATSPGM for Example 3-9 


c*+*+*+*+*+* 

c This program was produced by the 
c y 


ATOMCC translator version 7 10 
^opyight (C) 1985, Y. F. Chong 

V*+*+*+*+Hc+*+*+*+#+*^. # ^. + ^. # ^. 
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c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, 
c This program was written for the following inputs 
c 

COPTION DOUBLE,COMPLX 
C DIFF(Y,T,2) = 6*Y*Y + T 


c no instructions in second input block 


COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN, 

+ KTRDCV,KNTSTP.KTSTIF,KXPNUM,KDIGS,KENDFG.NTERMS,NOPT 
A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR 
B /CPASS/ START,END,ORDER 
C /DPASS/ H.HNEW 

D /PATHCM/ POINTS,VECTOR,KPTS.KPAST 
COMPLEX*16 START,END,POINTS(10).VECTOR,CZRO.DCMPLX 
COMPLEX ORDER 

DOUBLE PRECISION H.HNEW,AL 
COMPLEX*16 TMPS( 36, 1) 

CHARACTER*6 NAMES 
EQUIVALENCE (TMPS(1,1),Y(1)) 

COMPLEX*16 Y(36), T(2), TMPAAB(30), TMPAAA(30) 

COMPLEX*16 SHIFT 
DIMENSION NAMES(1) 

DATA NAMES( 1)/'Y.*/ 

Y(33) =1.1 

9 FORMAT(2X.11HAbove is at,1P2D12.4.9H step no.,14/) 

10 FORMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chong; S 
Aolution results./9H ******) 


CZRO = DCMPLX(0.D0.0.D0) 


c start of third input block 


0PEN(5,FILE«*DATA') 

READ(5,1010) MPRINT,NSTEPS.KPTS 
1010 FORMAT(315) 

WRITE(*,1010) MPRINT,NSTEPS.KPTS 
C 

C Read initial conditions 

READ(5,1020) Y(1),Y(2) 

1020 FORMAT(8F10.3) 

WRITE(*,1020) Y(1),Y(2) 

C 

C Read piecewise linear path 

READ(5,1020) (POINTS(I).1-1,KPTS) 
WRITE(*,1020) (POINTS(I),1-1.KPTS) 


c end of third input block 
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-- 

c--~!-l! te r ° d,U8 of mergence ond toke optimum step. 

_ _CALL CDRDCV(TMPS, LENVAR, NUMEQS. NAMES ) 

c--~l-!l rUCtl0nS fourth '"Put block 

GO TO (26.28). KENDFG 
26 AL = RADIUS 

H - DSIGN(AL.H) 

„ 00 T0 24 
24 START - START + HNEW*VECTOR 

IF(MPRINT.LT.5) GO TO 27 

K^Y&J 1 ) KNTSTP - START 

27 CON?Kr' 3,2) "•“ESOO.V(I). 7(2) 

WRITE(*,14) NSTEPS 

28 CONTINUE 

29 STOP 
END 

copies m th^°2?re 8 ct^ ?nto*ATSw2 ' n o b ' 0Cks 2 > 3 - ATOMCC 

changes such os decforotionl «r i S ° ? 0U ° r * r «spon S ible for ony 
Independent and depend^ CorToK r* 0 * mod * f 1 ^t ions. The * 
condition must hove both o reofin'd oVi^no"; 11'“" '' n ' U °' 

monnIr e in m whi^ n !he h path llVnilt/aUan ? 0mplex A T SPGM the 
integrotion is o p i ecewi se I i nlor^ih • S t ! PeC ‘ f ied ’ The poth of 
independent vorioble. The path coEsilti of^PTsTitV 10 ?* ° f the 
the complex array POINTS as shown in r , points stared In 

•< '• «.22.5 »<■>» 

Is best to keep l MPRINTe4° f Hieher *!/ 1 plo " # for singularities. It 

.— oenf;.^“. T ei„,. H :? h ;;,„ , j':;; P :;." pR, " T m,y , ~ <i * »• 

3.2.6 COPTION LENVAR=n - Series length 

LENvIS* S ihe vaIue*of ^ENVAR^may be^onoed'b S ^‘ e ? '* Stored in 

expression "LENVAR=n" on a COPTIOtTcoJr® Thrill 

used is controlled by the variable LENSER (see lecUon S^g)^’ 68 

Example 3-12. COPTION LENVAR=n 

COPTION LENVAR=100 

DIFF(POWER.TIME,4) - 3*DP2 
0P2 » DIFF(POWER.TIME.2) $ 

0PEN(5,FILE»’DATA’) 

.«-o?a?(6?,'?! 3 r ART ’ END ’ (po " ER <'>s>'.*) 
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WRITE(*,1010) START,END,(POWER(I),1-1,4) $ 

$ 

There are several circumstances under which you may wish to use 
a series length which differs from the 30-term series used by 
ATSPGM 

- The system of ODE's contains no functions or products of 
dependent variables. The cost of generating the series is 
then proportional to the series length (instead of the length 
squared), so using longer series may result in a faster 
execution time. 

- A series begins with many zero terms. Since ATSPGM requires 
series which have at least 8 nonzero terms, you must lengthen 
the series. 

Section 3.4.9 contains a discussion of the effect of series 
length on the execution time of ATSPGM. 


3.2.7 COPTION DUMP«n - Diagnostic messages 

This feature involves the operation of the ATOMCC translator 
Itself and will rarely be used. It was used during the development 
of the software and is documented here only for completeness. The 
form is COPTION DUMP*n, where n indicates the amount of dump to be 
written (on your screen). The following is dumped for each n. 

5 after lexical and syntactical analysis, 
and 4 after first optimization, 

and 3 after equation sorting and variable type identification, 

and 2 after implicit operator and operand analysis, 

and 1 after second optimization. 

It is suggested that users who wish to consult with the authors 
about a suspected bug in ATOMCC should have available the output 
from a run in which "DUMP-5" was specified and directed to a file 
for printing. 


3.3 Using bIock 2 


The second, third, and fourth blocks are not processed by 
ATOMCC in the same way as the first input block. ATOMCC merely 
copies the data from your ODEINP file directly into ATSPGM. 

The second block is optional and is used to insert 
non-executable FORTRAN statements at the beginning of ATSPGM. This 
block gives the user the ability to insert 'SUBROUTINE*, 

'FUNCTION', 'COMMON', 'DATA', and 'DIMENSION* into ATSPGM. Example 
3-13 shows where statements supplied in block 2 are inserted into 
ATSPGM. 
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3.3.1 Subroutine form of ATSPGM 

ATSPGM is normally generated as a main program which can then 
t k-??J V V he spec ' f,ed problem. The ATOMCC translator has 
ATc^ ap b li ty L t0 9*? erate subroutine or function forms for 
ATSPGM. The subroutine or function can then be called from a 
supplied main program, or from another ATOMCC-generated main 
program, to obtain the solution of the problem. 

A subroutine ATSPGM is specified by placing a SUBROUTINE 
statement In the second block. This statement is placed unchanged 
at the beginning of the generated code, so you have complete 
control of the name of the subroutine and Its parameter list. 
However, this also means that you have complete responsibility for 
passing values to and returning values from the generated program 

inftend'nf I b Y AT0MCC " have a RETURN statement 

instead of a STOP at Its end. Example 3-13 shows the ODEINP for a 

*og(s'i l n(x) named DIFEQU, which solves the equation f* = 

Example 3-13. Subroutine form of ATSPGM 

DIFF(F,X,1) = A10G(SIN(X) + F) $ 

SUBROUTINE DIFEQU(COND) $ 

F(1) = COND $ 

$ 

with Its calling program 
C Driver program for Exomple 3-13. 

c 

C A very simple subroutine, START and END are passed through COMMON. 

COMMON/CPASS/ START.END,ORDER 
1010 FORMAT(6F10.3) 

READ(5,1010) COND,START,END 
WRITE(*.1010) COND.START,END 
CALL DIFEQU(COND) 

STOP 

END 

„,„ n M ? ny ° f the variables used in ATSPGM appear in COMMON, so they 
??!! °! P ara, " e te r s • Values con be passed through the 

COMMON d- tel "P orar y variables, or they con be passed in 
COMMON by including the appropriate COMMON block in the callina 
program as illustrated by Example 3-13. 9 

3.3.2 User declarations 

You may need to declare the type of the additional variables 
you introduce into ATSPGM, if you use the double-precision or 

DOUBLF X OOMwnKi 0f nA^f PGM ; Y °V "'?? include appropriate DIMENSION, 
DOUBLE, COMMON, DATA, etc. in block 2. Any non-executable FORTRAN 

statements inserted in the second block ore copied into the 
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beginning of ATSPGM exactly as they are written, so you have total 
control over the statements entered. These statements must conform 
to FORTRAN specifications; ATOMCC does not check their syntax or 
the order of placement. 


3.3.3 Common blocks for user 

You may wish to use COMMON blocks. COMMON declarations may be 
included in block 2 like all non-executable FORTRAN statements 
discussed in Section 3.3.2. 

Note that many of the variables used in ATSPGM appear in COMMON 
blocks and must not be assigned to other blocks. 


3.4 Using block 3 


The third block must be used to specify the interval of 
integration and the initial conditions. It may also be used to 
change the default values of method-control variables. Default 
values are changed by inserting statements which assign new values 
to these variables. If desired, other statements can be inserted 
into ATSPGM at this point. The user should have an understanding 
of the form of ATSPGM and the relative position of the third block 
in ATSPGM. Examples 2-1 and 2-3 and Examples 3-1 and 3-3 are a 
pair of ODEINP files with their respective ATSPGM programs, you 
can better understand how the method-control variables work by 
studying the statements in the neighborhood of block 3. 


The assignment of values to each of the variables discussed in 
this Section may be done by: 


1. 

a READ statement (see Examples 2-1, 
3-12), 

2-2. 3-1, 

3-7, 3-11, 

2. 

an assignment statement (see Example 2-6), or 


3. 

being passed as temporary variables 
(see Example 3-13), or 

through a 

parameter 1ist 

4. 

common block shared with a driving 
3-13). 

main program (see Example 
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3.4.1 Initial conditions 

T . In?J n ! ti0 ! cond ! t,ons »utt be specified in the third block. 

wv ' '? 9 V S r ?? X ° = START 0f the de P«" d *"t variable, say 

yyy. d its derivatives ore assigned to the array yyy as follows — 

YYY(1) denotes yyy at xo, 

YYY(2) denotes yyy’ at xo, 

YYY(3) denotes yyy 1 ’ at xo, etc. 

nu "l be ^ of J n '* ,al conditions which must be specified for 
!orinM^ en h? n K vor ' °b 1 e equa I s the highest derivative of that 
var able which appears in the system of equations If the svstem 

!nc uded ? ^ 'nltiol^ondmons must 

included for the dependent variable y. ATOMCC does not check 

that h the'«M*I condi | ‘J on s h °ve been supplied, since it is possible 
that the series variable has been passed through a subroutine 

the°r!nuirlH S -'•'* is your responsibility to see that 
the required Initial conditions are defined. 

When ATSPGM is a subroutine, the series variable may be passed 

staled ln r ?h« " 8t -, In ? his COse * the initio1 conditions may be 
exeeu terf 0 P ^? P * r elements of the series array before ATSPGi/is 

*° P°ssing the series via the parameter 
fh o pass the initial conditions as temporary variables in 

the parameter I 1st. Assignment statements in the third block then 
elements^** V *° the oppro P riote dependent variable ar?ay 

th« ft?!,*? th0 *? * h0 ore familiar with the Taylor series method¬ 
ise initial conditions should be entered as explained above; that 

3.4.2 Parameters in the differential equations 


It is often interest 
solution on parameters i 
showed how the system of 
parameter are assigned, 
in Example 3-14. Here, a 
the parameter. See the 
observe that statement 
purpose. 


ing to explore the dependence of the 
n the ODE’s. Section 3.2.2 and Example 3-1 
equations is entered and how values of the 
A refined version of Example 3-1 is shown 
loop is used to read successive values of 
ob j ect program listing in Example 3-3 and 
28 CONTINUE * is provided by ATOMCC for this 


Example 3-14. Read parameters repeatedly. 


DIFFfX,T,2) = - ALPHA*X*R 
DIFF(Y,T,2) = - ALPHA*Y*R 
R = (X*X + Y*Y)**(-1.5) 

ALPHA * 0.65 « 

$ 

Read and echo print code, number 
0PEN(5,FILE»’DATA') 


of integration steps. 
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READ(5,1010) MPRINT.NSTEPS 


1010 FORMAT(2110) 

WRITE(*,1010) MPRINT.NSTEPS 


C 


C Read and echo Interval and initial conditions to be used each time. 
READ(5,1020) OLDSTR.OLDEND,X1.X2.Y1,Y2 
1020 FORMAT(6F10.3) 

WRITE(*,1020) OLDSTR.OLDEND.XI.X2.Y1.Y2 


C 


C Loop for different values of the parameter. 
DO 28 IPR0B=1,20 
READ(5,1020) ALPHA 
IF(ALPHA.EQ.0.0) STOP 
WRITE(*,1020) ALPHA 
START = OLDSTR 
END = OLDEND 
X(1) = XI 



Y(2) = Y2 $ 

WRITE(7.1030) KINTS.START.X(1).X(2).Y(1).Y(2) 


Y(2) = Y2 


1030 FORMAT(15.1P5E14.5) $ 


3.4.3 Solve a problem repeatedly 

In Example 3-14, the statement ’DO 28 IPROB*1,20’ is included 
in block 3 to solve the same system of differential equations as 
many as 20 times without restarting the program. The statement '28 
CONTINUE* near the end of ATSPGM is written by ATOMCC for this 
purpose. Within this loop, you may vary values of parameters as in 
this example, you may vary the initial conditions, or you may vary 
the method-control variables. 


3.4.4 START, END - Interval of integration 

The integration interval must be specified in the third block 
using the two reserved words START and END. Their use is 
illustrated by all the examples. 

If^a complex ATSPGM is being used, then the interval of 
integration is a piecewise linear path in the complex plane of the 
independent variable. The specification of complex paths of 
integration is discussed in Sections 3.4.13 and 3.4.14. 


3.4.5 NSTEPS - Number of integration steps, default«40 

The maximum number of integration steps taken during the 
solution is the variable NSTEPS. The default value (40) can be so 
small because the use of long series allows very large integration 
steps. You may change this value by inserting a statement In the 
third input block which assigns a new value to NSTEPS, or you may 
read in a value for NSTEPS from a data file. 

For some stiff problems and in searching for singularities in 
the complex plane, it is best to set NSTEPS at a large value. 
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3.4.6 H - Initial trial stepsize, default ■* 1.0 

The default value of the suggested Initial stepslze can be 
changed by assigning the desired value to the variable H In the 
third block. The term "suggested initial stepsize" is used because 
this value may be adjusted by ATSPGM before the first step is 
taken. This adjustment Is made if Its need is indicated by an 
analysis of the Taylor series for underflow/overflow. The user can 
rarely make a better choice than ATOMCC. 

For stiff problems, in addition to the adjustment of H in 
ATSPGM at the first integration step, the stepsize H is adjusted 
within DRDCV at every step. The adjustments at the first integra¬ 
tion step may need some manual assistance. In such cases, observe 
the values generated by the ATSPGM program and project forward to 
the next reasonable value and enter it for H. 


3.4.7 ERRLIM - Preset accuracy of the solution 

The local error tolerance is the variable ERRLIM. ATSPGM will 
keep the maximum local error less than ERRLIM. The magnitude of 
ERRLIM is automatically set by ATOMCC to be close to the computer 
round-off error in both single- and double-precision. You may set 
ERRLIM to be much larger; however, your results will become 
inaccurate. You may not set ERRLIM to be much smaller. 

The error analysis for normal problems is so precise that one 
can almost expect the global error to be under control. This is 
one numerical method where the global error is proportional to the 
local error. Therefore, to determine the magnitude of the global 
error, one only needs to run the solution a second time with an 
ERRLIM set one order of magnitude smaller than the first run and 
compare the two results. 


3.4.8 ADJSTF - Error control for stiff problems 

The error analysis for stiff problems is not nearly as well 
developed as the error analysis for normal problems. In solving 
stiff problems, it is necessary to make assumptions regarding both 
the exponential function and the polynomial that are used to fit 
the solution being sought. Therefore, an error-controlling 
parameter separate from ERRLIM is used. The default value for 
ADJSTF is 1.E-2. Also, the value of ERRLIM is fixed to 1.E-6 for 
stiff problems. The user is advised to change ADJSTF to lower 
values and make additional runs of the solution to be certain of 
its correctness. 

There is absolutely no connection between a particular value of 
ADJSTF and the magnitude of the error in the computations. The 
most that is claimed is that as the value of ADJSTF is adjusted 
smaller, there is likely to be a lowering of the computational 
error. Since the nature of stiff solutions is an approximation, 
there can be no true error control. And so, none is attempted. 
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3.4.9 LENSER - Length of series used, default-30 

The length of the Taylor series is the variable LENSER. This 
value may be changed by assigning a new value to LENSER in the 
third block. However, there are some restrictions governing how 
this is done. 

LENSER may be set to any integer between 15 and 30 without any 
other changes. Series of fewer than 15 terms should not be used. 

If a series of more than 30 terms is desired, the size of all 
series variables (LENVAR) must be increased (see Section 3.2.6). 

The user is reminded that the execution time is related to the 
length of the series. The default value of LENSER-30 have been 
found to be optmial for fast execution. 

In stiff solutions, LENSER is automatically set to either 15 or 
10 depending on the parameter MSTIFF. In these cases, the user 
cannot change these set values of LENSER without going into the 
subroutine DRDCV. 


3.4.10 MPRINT - Amount of print produced, default-4 

The amount of printout produced by ATSPGM during the solution 
of the problem is controlled by the variable MPRINT. Values of 
every dependent variable at each integration step is printed with 
an MPRINT-4. The user can change the default by assigning MPRINT a 
different value in the third block. The amount of printout 
produced for values of MPRINT is listed below. 

0 Used for timing purposes; printout is produced only when a 
fatal error occurs. 

1 No print is produced, but the loop controlled by RSET is 
activated to produce user controlled print (see Section 3.5.2). 

2 Print is produced only at points selected by the user. The 
printout consists of the integration step number, the value of 
the independent variable and the initial conditions for each 
dependent variable. 

4 (default) Print the information for 2 at every integration step. 
(In complex solutions, only the singularity locations are 
printed here.) 

5 In addition to the output under 4, the actual stepsize used 
at each integration step is printed. In stiff problems, the 
exponential function and the length of the polynomial are 
printed. In stiff problems, the estimated HSTF and the 
relative goodness of the exponential fit are printed. (In 
complex solutions, MPRINT-5 is equivalent to 4) 

6 In addition to the information for 5, print (a)the computed 
radius of convergence, (b)location of the singuIarIty(1es), 
and (c)whlch test was used to locate the poles. 
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7 In stiff problems, the entire results for the exponential fit 
are printed. 

8 All of MPRINT«6, plus (a)the estimated error in h/Rc, (b)the 
values of the elements of each series, and (c)messages for 
all tests used for the radius of convergence. 

10 All diagnostic messages including all the series terms. 

Users who will use ATOMCC often should try setting MPRINT-10 to 
become familiar with the Information available during the solution 
of a problem. 

The value of MPRINT may be dynamically controlled during the 
computation of a solution by inserting statements in the fourth 
block which test the current value of START (or KINTS), and set the 
value of MPRINT accordingly. 


3.4.11 DLTXPT - Print point increments, default - 0.0 

ATSPGM uses variables XPRINT and DLTXPT to control values of 
the independent variable for which print is produced. We will 
discuss a variety of ways these variables can be used. 

If DLTXPT*0.0, then print Is produced only at the integration 
steps chosen by the program. This is the default condition. 

Print is produced at equally spaced points by specifying DLTXPT 
= xxx (the desired spacing) as shown in Example 2-8 in Section 2.3. 
A statement may be placed in the third block which assigns the 
desired value to DLTXPT. You should also specify MPRINT-2. 
Otherwise print is produced both at your selected points and also 
at the integration steps selected by ATSPGM. MPRINT is discussed 
in Sect ion 3.4.10. 

The values of each dependent variable are printed at the 
equally spaced points by expanding a series which has already been 
computed. The integration does not step to the equally spaced 
points. Hence, requesting intermediate output has no effect on the 
number or size of integration steps taken. 

More creative print points are possible by the use of block 4. 
See Example 3-15 in Section 3.5.3. 

DLTXPT can be used in stiff solutions to generate output at 
desired values of the independent variable. DLTXPT cannot be used 
in conjuction with ZEROT, where the solution may be stopped for any 
value of any function. 


3.4.12 KTRDCV - Dynamic suppression of CALL RDCV 

KTRDCV can be used to speed up the execution of ATSPGM for 
systems of ODE’s for which some components of the solution do not 
constrain the integration stepsize. For KTRDCV=N, the series 
analysis is performed only for the first N components of the 
solution. You can generate ATSPGM once, run it to see the radii of 
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convergence of each component, and use KTRDCV on subsequent runs to 
reduce the execution time of ATSPGM. You should order the Input 
ODE’s such that those with larger radii are listed last. Careful 
study of the ATSPGM program for a sample system of ODE’s will help 
you see how KTRDCV works. 


3.4.13 KPTS - Number of points on complex path 

In Section 3.4.4, we discussed the specification of the 
interval of integration using START and END. If ATOMCC has been 
directed to generate complex object code (COPTION COMPLX, Sections 
3.2.4 or 3.4.5), then the path of integration is a piecewise linear 
path in the complex plane of the independent variable. See Example 
3-8 in Section 3.2.4. 

The variable KPTS is the number of vertices belonging to that 
piecewise linear path, including both of the endpoints. The 
complex array ’POINTS' holds the vertices. POINTS(I) becomes 
START, and POINTS(KPTS) becomes END. The value of the solution is 
printed at each element of POINTS. KPTS may be at most 10. 


3.4.14 POINTS - Complex path of integration 

The complex array 'POINTS' specifies the path of integration in 
the complex plane of the independent variable. Its use with KPTS 
is discussed in Section 3.4.13. There may be at most 10 points 
specified. 


3.4.15 MSTIFF®10 - Solutions which are entire 

Solutions which are entire (have no singularities in the finite 
plane), should not be solved using the ATOMCC system. It is a 
total waste of computing power to solve linear problems using 
ATOMCC. This is particularly true for linear 'stiff' problems. 

It can be EASILY show that ALL solutions that are entire can be 
solved in quasi-closed forms. This INCLUDES two-point boundary 
value problems! 

If ATOMCC recognizes that a system of ODE's involves no 
functions or products (an entire solution), it sets MSTIFF-10 in 
ATSPGM. Subroutine RDCV recognizes MSTIFF*10 as a flag for a 
special test for series that is entire. 


3.4.16 MSTIFF=20,21,22 - Stiff problems. 

This version of ATOMCC contains a double-precision algorithm to 
solve stiff problems. To use it, one can either set MSTIFF=20, or 
21, or 22. Other parameters that should be controlled are H, 

ADJSTF, and NSTEPS. It Is also desirable to set MPRINT to 7. at 
least initially, for observing the progress of the solution. If it 
should be evident that the problem is not really stiff, then it is 
most advisable to solve it as a normal problem. 
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MSTIFF-20 is the more conservative of the three algorithms. In 
this case, LENSER is set to be 15. The default value for ADJSTF, 
the error-controlling parameter, is a rather large 1.E-2. The user 
should run the stiff solution at least one more time with a 
somewhat smaller ADJSTF, say 1.E-3, to check on its validity. 

Since the default value for NSTEPS is 40, this should definitely be 
set at 500 or more, to be sure that the stiff solution can be 
completed. The initial stepsize H may need some adjustment by the 
user. He should study the H-adjustment messages from ATSPGM and 
take over control if and when the automatic adjustment is incapable 
of reaching a desirable value for H. When MSTIFF-20, those stiff 
problems that have steady-state solutions are identified. After 
which, one should perform some manual manipulations before 
re-submitting the problem to ATOMCC. 

When MSTIFF-21, LENSER is set to only 10. So, this option 
should be used only if the user is absolutely certain that the 
problem under study is very stiff. The solution of stiff problems 
under this option is considerably faster than that for MSTIFF-20, 
because not only are the series shorter, the integration stepsizes 
are considerably larger. The same statements as above applies for 
the parameters H, ADJSTF, and NSTEPS. (One of the Enright-Hull set 
of stiff problems, E2, was solved by ATOMCC in one step!) There is 
no attempt to identify steady-state solutions when MSTIFF-21. 

MSTIFF-22 is identical to MSTIFF-20 except for the fact that 
there is no attempt to identify steady-state solutions. 

As mentioned above, the stiff algorithm is written in double¬ 
precision. It is simply not cost effective to solve such problems 
using single-precision. There is one other restriction on stiff 
problems. All such problems must be stated as first-degree ODE's. 

The regular printing option, DLTXPT, functions properly in 
stiff solutions. So, it is possible to obtain uniformly spaced 
print points or IogarithmicaIy spaced print points. 


3.4.16.1 Steady-State Stiff Problems 

There are some stiff problems that approach steady-state solu¬ 
tions. Sometimes this occurs with all of the functions becoming 
constant simultaneously. In such a case, the ATOMCC solution will 
stop and points out the fact that every function seem to have 
reached constant values. The user can decrease ADJSTF and repeat 
the solution to verify the truth of this fact. He can also run the 
problem with MSTIFF-22 and observe the perpetual singleness of the 
resuIts. 

In other instances, a particular function reaches constancy 
before any of the others. When this happens, the following message 
will be printed, with obvious meaning. 

The function Y4.... is constant at 3.115283D-04 

Look for a steady-state solution. 

Set all derivatives to zero, use the value of Y4.... given above, 
and solve for the other functions in easy situations. 

Then, re-submit to ATOMCC. Use MSTIFF-21 or 22, do not use MSTIFF-20. 
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This example Is for the problem CHEM6 out of the Enright-Hull 
set of chemical stiff problems. This solution stopped at time = 
0.0561, where the solution had hardly gotten started. After 
solving the easy cases as suggested, the ATOMCC solution of the 
re-submitted problem reached the final time of 1000 in 26 steps 
using MSTIFF=21! 

The equational input for the first ATOMCC run is as follows. 

DIFF(Y1,T,1) = 1.3*(Y3-Y1) + 10400*AK*Y2 
DIFF(Y2,T,1) = 1880*(Y4 - Y2*(1+AK)) 

DIFF(Y3, T, 1) = 1752 - 269*Y3 + 267*Y1 
DIFF(Y4,T,1) = 0.1 + 320*Y2 - 321*Y4 
AK = EXP(20.7 - 1500/Y1) 

The equational input for the second ATOMCC run, after encountering 
the constancy message is as follows. 

DIFF(Y1,T,1) = 1.3*(Y3-Y1) + 10400*AK*Y2 
DIFF(Y2,T,1) = 1880*(Y4 - Y2*(1+AK)) 

Y3 = 1752/269 + 267/269*Y1 

Y4 = 3.115283E-04 

AK = EXP(20.7 - 1500/Y1) 

The differences between to two inputs are in the third and fourth 
equations. 


3.5 Using bIock 4 


ATOMCC copies the fourth block directly into ATSPGM near the 
end of the code for each integration step. Example 3-3 in Section 
3.1.3 shows the location of block 4 in ATSPGM. The fourth block is 
used to tailor ATSPGM to your special requirements. Several 
examples are provided in Section 3.1.1, but many other creative 
uses are possible. Most applications require a good knowledge of 
the ATOMCC system for solving ODE’s. 


3.5.1 Automatic printing of output points 

The ATSPGM program automatically prints the values of each 
component of the solution at each integration step (see Example 2-7 
in Section 2.2.6). It can print the same information at equally 
spaced points you select using DLTXPT (see Section 3.4.11). This 
technique for generating output at equally spaced points requires 
no use of block 4, but it will help you to understand subsequent 
sections if you understand how ATSPGM generates this equally spaced 
output. Please refer to the object code in Example 3-3 in Section 
3.1.3 as you read. 

The points selected for output do not affect the integration 
steps so that the local error remains proportional to the global 
error. For each output point within an integration step, the 
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solution is computed by evaluating Its Taylor series. Inside the 
subroutine RSET, each output point within the the Integration step 
Is controlled by a loop which begins with the statement *24 IF 
(KENDFG.EQ.3) KENDFG*1* and ends with the statement *G0 TO 
(26.28,24), KENDFG*. KENDFG is a flag which controls the loop. 

Subroutine RDCV sets KENDFG*2 if the current steps reaches END, 
otherwise KENDFG=1. Subroutine RSET determines whether the next 
output point (XPRINT) lies within the next step of integration. If 
not, RSET leaves KENDFG unchanged (1 or 2) and stores the initial 
conditions required by the next step. If there is a print point 
within the next integration step, RSET prints the solution at that 
output point (suppressed if MPRINT*0 or 1), stores values of the 
series and its derivatives as elements LENSER+1, LENSER+2,... in 
the series, and sets KENDFG*3. Then, the *G0 TO* in ATSPGM returns 
to label 24 to handle additional output points within the next 
integration step. Once all of the output points within the next 
step have been passed, RSET returns KENDFG to its original value (1 
or 2), and the solution proceeds forward. 

You can use DLTXPT to generate output at equally spaced points 
without understanding how that output is generated, but if you wish 
to produce some special output as discussed in the following 
Sections, this understanding is necessary. 


3.5.2 User controlled printing of output points 

The object program automatically prints the values of each 
component of the solution at each integration step (see Example 2-7 
in Section 2.2.6). The method used to produce output at user 
selected points is discussed in Section 3.5.2. However, you may use 
block 4 as shown in Example 3-1 in Section 3.1.1 to produce output 
according to your particular needs. 

The execution time for ATSPGM is sensitive to the amount of 
output produced. Unless you are interested in the automatically 
produced output, place MPRINT=1 in block 3. Then, RSET controls the 
necessary looping as discussed in Section 3.5.1, but it produces no 
output. This yields the solution at equally spaced points. 

Unequal spacing can be achieved by changing DLTXPT within block 4. 
Example 3-15 in Section 3.5.3 shows how to obtain the solution at 
logarithmically spaced points. 

Many variables are accessible for your use in block 4. The 
elements of the array for each dependent variable, [y(LENSER+1), 
y(LENSER+2), etc.], contain the values of that variable and its 
derivatives evaluated at XPRINT. The user can therefore print 
these values totally independent from the print produced by 
ATSPGM. Additional usable values are stored in the top three 
positions of the series; y(LENVAR-2) is the series length actually 
used for that particular variable, y(LENVAR-1) is the multiplying 
constant for the exponential function in stiff solutions, and 
y(LENVAR) is the exponential coefficient in stiff solutions. 
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3.5.3 Logarithmic spacing of output points 

The techniques discussed in Sections 3.5.1 and 3.5.2 produce 
values of the solution at equally spaced points. Output at 
non-uniformly spaced points is obtained by adjusting DLTXPT and 
XPRT3 within block 4 as shown by Example 3-15. The print points are 
at r = 100, 50, 20, 10, 5, 2, etc. This example also shows that 
problems can be integrated in the negative direction. 

Example 3-15. Logarithmic print. 


DIFF(F,R,2) = (F**3 - F)/R**2 $ 

$ 

START = 100.0 
END = 1.0E-8 
F(1) = 0.99 
F(2) = 1.0E-4 
DLTXPT * -50.0 
NPTR = 1 
$ 

IF(KENDFG .NE. 3) GO TO 25 
MPRINT = 2 

GO TO (501,503,502), NPTR 

501 DLTXPT = - 0.6*XPRINT 
GO TO 504 

502 NPTR = 0 

503 DLTXPT = - 0.5*XPRINT 

504 NPTR « NPTR + 1 

XPRT3 « XPRINT + DLTXPT $ 


3.5.4 ZEROT - Stopping and printing at roots of variables 

It is often of interest to locate points at which a component 
of the solution has a root or assumes some specified value. The 
subroutine ZEROT, in the ATOMCC subroutine library in single- 
precision, do automatically solve such problems. DZEROT Is the 
double-precision version. 

The form of the CALL is 

CALL ZEROT(NUMBER,Y,ROOT.KEY,TMPS,LENVAR,NUMEQS) 

where 

NUMBER is the index of the Y series term whose root is sought, 

Y is the variable whose root is desired, 

ROOT is the value Y is to assume (= 0 for a root), 

KEY is 1 if Y is a dependent variable, or 

0 if Y is not a dependent variable. 

The arguements TMPS, LENVAR, and NUMEQS must be exactly as 
written above. 


BYTE LISTINGS SUPPLEMENT 305 





April 


r \ 


(Internol page reference for monual.doc) 


Example 3-16. Rootffnding with ZEROT. 


DIFF(Y,T,2) = 6 *Y*Y + T $ 

START = 0.0 
END = 1.15 
ROOT = 20.0 

Y( 1 ) - 1.0 
Y( 2 ) = 0.0 
$ 

CALL ZEROT( 1 ,Y,ROOT, 1 ) 

When the variable whose rAA* * . * 

rr*- ,h> ^r.r.v 

c :n^%Z Y ilV ) 

TEMP . START * KNE. 

ie, 0 • reMP ’ VARYC1 )• V *«XC2) 

GO TO 25 $ 

information os shown*in *the*se 0t " ecessar Y for one to print the 
stop and restart the , 0 n SSKmo??*' (1 The / TSP ^ P?og?«doe. 
the output is controlled by MPRIN^ ° y at the 8X0ct root and 

—j’ss'rss’ir.s-jn^sfi-.a.s: r ,obi - - —•-< 

ser.es is not convergent over thl.If ,ze being used. If the 
possibly locate the Foot with 1 S# ' * hen ZER0T cannot 
two instances where this convergence ^.,V occ “ r « c y* There are 
IS where the prfntfna stan* k! 9 u requirement Is not met One 
OLTXPT. and the other fs Z^ a U " der the ^ntFol of 

p T ?o e b^ e ’ ZER ° T us*d°for o # non-riro n^stiff 

value; however^obv^ous ly^heJ^NUMBER* is°!' *' V ? (non_zero ) integer 
the root will suffer. NUMBER 18 V8r Y 'orge the accuracy of 

3.5.5 Finding singularities in real solutions 
(This Information Is oniv *u 

finding the conjugate pairs of s ingjtar m erS ? h ° are inter «sted in 
oxis. For a more detailed studv nf ° r ties closest to the real 
invoke COPTION COMPLX, Section^ 3 . 2 [ 4 ) lar * t' ®s, the user sho°u.d 

-n-iJtK^nfoJSK: iLX%i:zv&'r ; s its abMity ** p™.* 

RDCV estimates the location and oidlr ni /? r exam P ,e ' subroutine 
each integration step In order to rnmm°+ p '’' mar y singularities at 
Th.s information may be printed us ing^PRIN^fsirSeluon’ 2e ' 
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3.4.10). However, several steps are usually required to pass 
between a conjugate pair of singularities, so several different 
estimates for each location are written. Estimates made close to 
the singularities are more accurate than estimates made from 
further away. 

Example 3-17 prints only one estimate for the location and 
order of each conjugate pair of singularities. That estimate is 
written on the step which has just begun to recede from the 
estimated location. Hence that step is one of the two steps 
closest to the singularity pair. 

Example 3-17. Finding singularities in real solutions 


COPTION DOUBLE 
C 

C Test dynamic printing of singularity positions. 

C 

DIFF(Y1,T,1) - 2*(Y1 - Y1*Y2) 

DIFF(Y2,T,1) = Y1*Y2 - Y2 $ 

$ 

ERRLIM = 1.0E-6 
START =0.0 
END = 20.0 
Y1(1) = 1.0 
Y2(1) = 3.0 
MPRINT = 10 
PRTSNG = START 
SNGTOL =0.1 
WRITE(8,2010) 

2010 FORMAT(///6H Step,9X,IHx,10X,2HRc,8X,4HReaI, 

A 8X,4HImag,7X,5Horder,7X,5Herror/) 

$ 

C 

C Print locations of singularities. 

C 

WRITEf*,2010) 

WRITE(*,2020) KINTS.START,RADIUS,RCREAL,RCIMAG,ORDER,RDCERR 
C 

C If this is a user print step, then continue. 

IF(KENDFG.EQ.3) GO TO 25 
IF(KINTS.EQ.NSTEPS) GO t0 102 
C If this is a normal step, then jump. 

IF(KENDFG.EQ.I) GO TO 105 

C Handle the last step - we might be approaching a singularity 
C if we have already printed this primary singularity, then continue. 

102 IF(ABS(RCREAL-PRTSNG).LT.SNGTOL) GO TO 25 
C If RDCV was uncertain, then continue. 

IF(RDCERR.GE.1.0) GO TO 25 

WRITE(8,2020) KINTS,START,RADIUS,RCREAL,RCIMAG,ORDER,RDCERR 
2020 FORMAT(14,1P6E12.3) 

GO TO 25 
C 

C Handle a normal step. 

C 

C If confused, then continue. 

105 IF(RDCERR.GE.1.0) GO TO 25 
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C If °PProaching the primary singularity, then continue 
IF((START-RCREAL)*H.LE.0.0) GO TO 25 conxmue - 
C If already printed, then continue. 

IF(ABS(RCREAL-PRTSNG).LT.SNGTOL) GO TO 25 

prtsngVrcre al 1 NT $ ’ START ' RAD1US * RCREAL1RCIMAG • 0RDER • RDCERR 

Example 3—18. Printed locations 


Step x 

1 0.000E+00 

9 5.180E+00 

19 1.083E+01 

28 1.627E+01 


Rc 

5.978E-01 
4.954E-01 
5.297E-01 
5.145E-01 


Rea I 

-3.364E-01 
5.151E+00 
1.063E+01 
1.612E+01 


Imag 

4.941E-01 
4.945E-01 
4.943E-01 
4.943E-01 


order 

9.457E-01 

9.784E-01 

9.595E-01 

9.662E-01 


error 

5.588E-04 
7.08IE-04 
2.888E-04 
2.660E-04 


3.5.6 Stopping short of a singularity 

If one component of the solution has a singularity inside the 

on ^ that Ini ,nt *9 r otion, then the problem does not have a solution 
on that interval, so the integration process should stop. ATSPGM 
stops when NSTEPS steps have been taken (see Section 345) or it 
stops when the integration stepsize is so small relative to the 
current point of expansion that the solution would not advance 


3.6 Editing of ATSPGM 


direct Iv* into AT 9 Pru b | 0cks 2> 3 ‘ and 4 to In»«rt FORTRAN code 
directly Into ATSPGM gives you a very powerful and flexible tool 

you may have needs which can only be met by editing ATSPGM 

oroduo f * Section 3.6.1 uses the relatively common problem of 

approach? eff ' C,ent output at specified points to Illustrate the 

3.6.1 TERM - Fast generation of printing at output points 

The printing of solution values at equally spaced points has 
already been discussed in Sections 2 . 3 , 3 . 4 . 11 , 35?. and 3 52 
The technique discussed in Section 3.5.2 can be used to generate’ 

select ° Th° f the ab °ut solution at any Joints^ou 

select. The execution time is much faster using MPRINT =1 to 
suppress printing by RSET, than with MPRINT -2 or 4 

? X#C “ U °? *'?• of ATSPGM can b ® further reduced by 
?ntearitinn k° P n ?,f 0r COCh print point witb in the current 

seMes fir thl ? 9 subrout ine TERM to evaluate the 

2 eiSp” s^'s? ony p °""- ii,i! i* 
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Example 3-19. TERM source listing 


C SUBROUTINE TERM (SERIES,NTERMS,T,WORKAR) 

C 

C ATOMCC-LIBRARY, COPYRIGHT (C) 1983. 

C 

C EVALUATES SERIES AND ITS DERIVATIVES AT T 
C 

C AT ENTRY. 'SERIES ‘ CONTAINS A SERIES EXPANDED AT SOME POINT 
C ’START’ WITH A STEP OF ’H’. 

C 

C AT EXIT, WORKAR(I) = FUNCTION EVALUATED AT T 
C WORKAR(2) - DERIVATIVE OF FUNCTION EVALUATED AT T 

C ... 

C WORKAR(NTERMS) - NTERMS - 1 DERIVATIVE EVALUATED AT T 

C 

C PARAMETERS: 

C SERIES - SERIES BEING SUMMED 

C NTERMS - NUMBER OF INITIAL CONDITIONS NEEDED 

C T - POINT AT WHICH SERIES IS TO BE EVALUATED 

C WORKAR - WORK AREA. SAME TYPE AS SERIES. DIMENSION NTERMS 

C 

SUBROUTINE TERM (SERIES, NTERMS. T. WORKAR) 

C******** DATA DECLARATIONS 

DIMENSION SERIES(I). WORKAR(I) 

COMMON /CPASS/START,END.ORDER 
A /DPASS/H,HNEW,XPRINT,DLTXPT 

+ /IPASS/LENSER.LENVAR.MPRINT,MSTIFF,LRUN.KTRDCV, 

+ INTSTP,KTSTIF.KXPNUM.KDIGS.KENDFG,NTERMS 

C******** COMPUTE INITIAL CONDITIONS ANO STORE THEM IN WORK AREA 
RATIO = (T-START)/H 
DUMMY = H/FLOAT(LENSER) 

DO 40 1-1,NTERMS 
ILEN = LENSER - I - 1 
DUMMY - DUMMY*FLOAT(LENSER - I + 1)/H 
DLOOP - DUMMY 

SUM = SERIES(LENSER)*RATIO*DLOOP 
DO 30 J-1.ILEN 
LMJ - LENSER - J 

DLOOP - DLOOP*FLOAT(LMJ-I+1)/FLOAT(LMJ) 

SUM = (SUM + DLOOP*SERIES(LMJ))*RATIO 
30 CONTINUE 

WORKAR(I) - SUM + DLOOP*SERIES(I)/FLOAT(I) 

40 CONTINUE 
c******** RETURN 
9999 RETURN 
END 

To illustrate the use of subroutine TERM as an example of 
editing ATSPGM, Example 3—20 shows the ODEINP file which was used 
to generate ATSPGM listed as Example 3-21. Three arrays have been 
dimensioned to hold the results computed by TERM, and new variables 
DXP and FIRSTX have been defined to fill roles analogous to DLTXPT 
and XPRINT. 
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Example 3-20. ODEINP for TERM example 

S = 10.0 

DIFFfX.T,31 = Y - E*S*X 
0IFF(Y.T,3) = - X*Z + X - E*Y 
DIFF(Z,T,3) = X*Y - E*B*Z 
E = 0.02 
B = 8 .0/3.0 $ 

DIMENSKIN USER 1 (3),USER2(3),USER3(3) $ 

OPEN(7,FILE- 1 DATA’) K J 

openCs.file-’fast 1 .STATUS- 1 NEW 1 ) 

READ(7, * 1 X(1),Y(l).Z(1) 

READ(7, *) X(2).Y(2),Z(2) 

READf7, *) X(3).Y(3).Z(3) 

READ(7,») START,ENO.DLTXPT 
READ(7,*) DXP 
FIRSTX = START 

1 01 oTorSaT(3 F J? } 4) 1 11 } Kh U111 START1END1DLTXPT1FIR STX. END. DXP 
NSTEPS = 5 
WRITE(8, 1020 ) 

1020 F0RMAT(3X,IHt,5X,1Hx,7X,2Hx’,6X,3Hx ’ 1 

+^5X,1Hy,7X,2Hy 1 ,6X,3Hy' 1 ,5X,1Hz,7X,2Hz 1 ,6X,3Hz 1 ’/) $ 

with doto file 

1.0.3.0,5.0 
0 . 0 , 0 . 0 , 0.0 
- 1 . 0 , 0 . 0 , 1.0 
0 . 0 ,5. 0 , 0 .5 
0.5 

CALL T RDrv°l!nt ing l' 1 ? 68 .®' code must be Inserted just below the 

ZITe xXTr5l 2 i n8ide ATSPGM - A P ° rti0n ^ resJVor* 

Example 3-21. Object program for Example 3-20 
CALL RDCV(TMPS,LENVAR,NUMEQS) 

C= 1 ! 00 = If(fIrst^GeTsTART+HNEW)^GO*TO*24* S * 

CALL TERM(X,3,FIRSTX,USER 1 ) 

CALL TERM(Y,3,FIRSTX.USER 2 ) 

CALL TERM(Z,3,FIRSTX,USER3) 

WRITE(8,1030) FIRSTX,USER1.USER2 USER 3 
1030 FORMAT(1X.F3.1.1P9E8.1) lUatRZlUSER3 
FIRSTX = FIRSTX + DXP 
GO TO 100 

C== ^T =,!=!= r = / end of user inserted lines. 

24 IF(KENDFG.EQ.3) KENDFG = 1 
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Example 3-22. Output for Example 3-20 


t x 


x* x*• y 


y* y* * z 


z * 


z 


» • 


0.0 1.0E+00 0.0E+00-1.0E+00 
0.5 9.3E-01-1.5E-01 3.9E-01 
1.0 9.6E-01 3.7E-01 1.6E+00 
1.5 1.4E+00 1.4E+00 2.3E+00 


3.0E+00 0.0E+00 0.0E+00 
2.9E+00-5.0E-01-2.0E+00 
2.3E+00-2.0E+00-4.1E+00 
6 .9E-01-4.8E+00-7.4E+00 


5.0E+00 0.0E+00 1.0E+0 
5.1E+00 8.3E-01 2.3E+0 
5.9E+00 2.3E+00 3.4E+0 
7.5E+00 4.2E+00 4.1E+0 


3.7 Large systems 


As supplied to you, the ATOMCC translator can handle up to 900 
equations. If you should have a need to increase this limit, a 
special program can be easily prepared. 


3.8 Solving ODE’s in the complex domain 


The ATOMCC compiler allows for the solution of ODE’s in the 
complex domain. This unique capability can be used to explore the 
structure of the singularities in the complex domain of non-linear 
problems. Linear problems, of course, have entire solution 
functions and therefore do not have any singularities of interest 
in the finite complex plane. Non-linear problems may have 
singularities which cover the entire complex plane. 

There are essentially two types of non-linear problems; those 
with definite limit cycles, and those with strange attractors. For 
the former, the singularities form a regular lattice in the complex 
plane. For the latter, the singularities form structures that defy 
simple descriptions. The purpose of solving ODE’s in the complex 
domain is to study the structures formed by the singularities. The 
ATOMCC compiler is well suited for this task, and it is the only 
method extant that is capable of calculating the precise location 
and order of all the singularities in a finite region of the 
complex plane of an ODE solution. 

It is simple to use the ATOMCC compiler to search for the 
singularities. First, you must insert a COPTION COMPLX card as the 
first card in ODEINP. This will cause the ATOMCC compiler to 
generate ATSPGM that will solve the ODE using paths into the 
complex domain. Secondly, you must specify the path to be taken by 
the solution. This path is fixed by specifying the vertices of 
straight-line segments in the path. The path taken must be 
composed of straight-line segments. The first vertex is of course 
the starting point of the solution. A maximum of ten vertices may 
be specified. These vertices are to be placed into an array called 
POINTS, and the number of vertices used is stored in the variable 
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KPTS. The ATOMCC solution will follow the path thus specified and 
locate all the singularities near this path. 

Since the ATOMCC solution will find all the singularities near 
the path specified by the user, certain problems may occur. First, 
the user may have by accident specified a path exactly midway 
between two singularities. In this event, there will be no 
information output from ATOMCC. The path must be slightly closer 
to one singularity than another; otherwise, ATOMCC cannot find the 
nearest singularity. Secondly, the user may have by accident 
specified a path that is too close to a singularity, or perhaps 
even a path that is directly pointed at a singularity. In this 
event, the ATOMCC solution will grind away and take very small 
steps. The information from ATOMCC beyond any such close encounter 
will be unreliable. In all cases, the user is well advised to 
change the path in the complex plane ever so slightly and make a 
second run to double check his results. In our experience, it is 
best to perform the complex integrations using double precision. 
Insert a COPTION DOUBLE,COMPLX card as the first card In your 
input. With just minimal experience, the user will find the use of 
ATOMCC in the complex plane to be fast and easy. 

For good results, the first leg of the path into the complex 
domain should be directed straight up in the imaginary direction. 

Do not make the first leg of the path coincident with the real 
axis. This introduces subtraction errors into the complex 
solution. 

When there are complex constants In the equations, the user is 
entirely responsible for seeing to it that those constants are 
properly specified with TYPE declarations in block 2, and the 
values are properly entered as CMPLX(—,—) or DCMPLX(—,—) in 
block 3. The reason for this requirement on the part of the user is 
because if the facts are otherwise, the user may then be required 
to use an editor to delete some possibly incorrect specification 
written by ATOMCC. It is better to be a bit short and correct than 
to be long and in error. 
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dragon.doc 
TEXT 

Programming Insight: "DRAGON" Bruce R. Land. 
ApriI page 137. 


Screen #1 

( begin Dragon curve ) 

CREATE CURVE ( a FORGETabIe name) 

CARTESIAN OFF 

: RECURS SMUDGE ; IMMEDIATE ( trick verb for recursion) 

VARIABLE ANGLE 
VARIABLE XCOOD 
VARIABLE YCOOD 
VARIABLE STEPSIZE 

: TURN ( deltangle— | turn sign*delta) 

ANGLE +! ; 

2 4 THRU 


Screen #2 

: MOVE ( — | takes a step in present turtle direction) 
STEPSIZE @ DUP 

ANGLE @ COS * 10000 / ( r* cos of theta) XCOOD @ + 

DUP ( newX) XCOOD ! ( update X) 

SWAP 

ANGLE @ SIN * 10000 / ( r* sine theta ) YCOOD @ + 

DUP ( newY) YCOOD ! ( update Y) 

DRAW.TO ; 


Screen #3 

: DRAGON ( sign level— | ) 

DUP ( level) 0= 

IF ( at bottom of recursion) 

DROP ( level) DROP ( sign) MOVE ( by stepsize) 
ELSE 

OVER 45 * TURN ( getsign and turn) 

1 ( newsign) 

OVER 1- ( I eve 1*1 eve 1-1) 

RECURS DRAGON RECURS 

OVER -90 * TURN ( getsign & turn) 

-1 ( newsign) ( edit to +1 for diff curve) 

OVER 1- ( I eve I * I eve 1-1) 

RECURS DRAGON RECURS 

DROP ( input level) 45 * TURN ( getsign and turn) 
THEN ; 

Screen #4 

: DCURVE (level —| ) 

( init pen position) 

PAGE 100 XCOOD ! 90 YCOOD ! 360 6 * ANGLE ! 

WHITE PENPAT XCOOD @ YCOOD @ MOVE.TO 

PEN.NORMAL 
1 STEPSIZE 1 
1 SWAP ( level) DRAGON 

WHITE PENPAT 4 10 MOVE.TO PEN.NORMAL ; 


{continued) 
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matinv.bas 
TEXT 

"The Inversion of Large Matrices" Thomas E. Phipps Jr. 
April, page 181. 


10 REM Real-entry matrix inversion (Pan-Reif method) 

20 REM Program by Thomas E. Phipps, Jr. 

30 REM Ref= Proc. 17th Annual ACM Sympos. on Theory 
40 REM of Computing, Providence, RI, May 1985 
50 REM Random-entry matrices, single precision 
60 REM Quartic modification of Newton’s iteration 
70 INPUT "Run number * ";RN 

80 REM N data is in line 640, D1 data in line 660 
90 READ N, D1:RANDOMIZE RN:OPTION BASE 1 

100 REM Can optionally insert DEFDBL A,B,E,X instruction here 
110 REM A is the matrix to invert, B is the approximate inverse of A, E is the 
error matrix for the inverse, and X is a temporary storage matrix as 
explained in the BYTE article. 

120 DIM A(N,N),B(N,N),E(N,N),X(N,N) 

130 REM Generate random-entry A-matrix. For real data, replace 140 by an INPUT 
statement and input normalized data (each element of A is divided by the 
largest element, L). Delete line 150. B and D1 must be multiplied by L 
Iater. 

140 FOR 1-1 TO N:FOR J-1 TO N:A(I,J)-RND(1):NEXT :NEXT 

150 FOR 1-1 TO N:FOR J-1 TO N:IF RND(1)<.5 THEN A(I,J)—A(I,J) 

160 NEXT :NEXT 

170 CLS:TIME$-"00" ’Start clock 

180 REM Eva I. t by Pan-Reif eq 8 in BYTE article 

190 FOR 1-1 TO N:R0-0:S0=0:FOR J-1 TO N 

200 R0=R0+ABS(A(I,J)):S0=S0+ABS(A(J,I)):NEXT J 

210 X(1,I)-R0:E(1,I)-S0:NEXT I:T1«0:T2=0 

220 FOR 1-1 TO N:IF X(1,I)>T1 THEN T1»X(1,I) 

230 IF E(1,I)>T2 THEN T2-E(1,I) 

240 NEXT I:T«1/(T1*T2) 

250 REM Eva I. initial B-matrix 

260 FOR 1-1 TO N:FOR J-1 TO N:B(I,J)»T*A(J,I):NEXT :NEXT :H=0 
270 PRINT 

"ITER."TAB(10);"E(1,1)"TAB(28);"E(1,N)"TAB(46);"B(1,1)"TAB(64);"B(1,N)" 

280 REM Eva I. error matrix E 

290 FOR 1-1 TO N:FOR K-1 TO N:Z=0:FOR J-1 TO N 

300 Z=Z+B(I,J)*A(J,K):NEXT J:E(I,K)«-Z:NEXT K:NEXT I 

310 FOR 1=1 TO N:E(I,I)-1+E(I,I):NEXT I 

320 BEEP:PRINT H;TAB(6);E(1,1);TAB(24);E(1,N);TAB(42);B(1,1);TAB(60);B(1,N) 

330 IF H>50 THEN PRINT "STUCK!":BEEP:BEEP:GOTO 620 
340 REM Test for escape from loop 

350 FOR 1-1 TO N:FOR J-1 TO N:IF ABS(E(I,J))>D1 THEN 370 
360 NEXT :NEXT :GOTO 440 

370 H-H+1 ’Newton’s iteration (quartic modification) 

380 FOR 1=1 TO N:X(1,I)«1+(1+(1+(1+E(I,I))*E(I,I))*E(I,I))*E(I,I):NEXT 

390 FOR 1=1 TO N:FOR J-1 TO N:E(I,J)=X(1,I)*E(I,J):NEXT :E(I.I)=1+E(I,I):NEXT 

400 FOR 1=1 TO N:FOR K«1 TO N:W=0:FOR J-1 TO N 

410 W=W+E(I,J)*B(J,K):NEXT J:X(I,K)=W:NEXT K:NEXT I 

420 FOR 1=1 TO N:FOR J=1 TO N:B(I,J)=X(I,J):NEXT :NEXT 

430 GOTO 280 

440 REM output follows 

450 T$=TIME$:BEEP:BEEP:BEEP:PRINT "Run number";RN,"Duration = ";T$ 

460 PRINT "No. iter.=";H,"Matrix dim.="N,"Max. error=";D1 
470 INPUT "Another iteration (y,n)";C$:IF C$="Y" OR C$="y" THEN 
TIME$-"00":GOTO 370 

480 PRINT "The maximum error was calculated by multiplying A^-1*A." 

490 PRINT "As a check on the true error In the approximated inverse matrix" 

500 PRINT "the maximum error in A*A^-1 will now be determined." 

510 ERASE X 'recycle the temporary storage matrix for errors in A*A~-1 

520 DIM X(N,N) 

530 FOR 1=1 TO N:FOR J=1 TO N:FOR K-1 TO N 
540 X(I,K)-X(I,K)+A(I,J)*B(J,K) 

550 NEXT :NEXT :NEXT 

560 REM You may print out the matrix and its inverse by placing a PRINT 
command for A and B in the following loop. 

570 FOR 1-1 TO N:FOR J-1 TO N 

580 TEST.VAL=ABS(X(I,J)):IF I-J THEN TEST.VAL-ABS(1-TEST.VAL) 

590 IF TEST.VAL>MAX.ERROR THEN MAX.ERROR-TEST.VAL 
600 NEXT :NEXT 
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610 PRINT "The max. error found this way is ";MAX.ERROR 
620 END 

630 REM Matrix dim. N - 
640 DATA 10 

650 REM Error criterion D1 * 

660 DATA 3E-6 
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mainprog.bas 
TEXT 

Programming Insight: "Subroutine Overlays in GW-BASIC," Mike Carmichael. 
May, page 151. Also download routine.sub. 


1000 

1005 

1010 

1020 

1030 

1040 

1060 

1070 

2000 

2001 

2002 

2003 

2020 

2030 

2040 

2050 

2060 

2070 

2080 

2100 

8000 

8001 

8002 

8003 

8010 

8020 

8030 

8040 


main program demo module 
MAINPROG 


COMMON 

DEFINT H,I,J,K,L 
LLOAD - 1 

FLNME$ - "routine.bin": D$ - M c:" 

*********************************** 
• main driver 


GOSUB 12000 * explanation 
GOSUB 8000 * load * rout 1ne.sub * 
GOSUB 30000 • using ... 

GOSUB 31000 • _ ’routine.sub* 

*********************************** 

• normal program ending 

STOP 

'A********************************* 

* load / save routine.sub 


GOSUB 10000 * * set I load switch 

ON ERROR GOTO 11000 

GOSUB 19900 * position currpos 

IF LLOAD THEN BLOAD FL$, CURRPOS ELSE BSAVE FL$, 


CURRPOS, 1000 

8050 IF LLOAD THEN GOSUB 8100 
8060 RETURN 

8100 '********************************** 

8101 * adjust binary line 

8102 * pointers when loading binary 

8103 * subroutines 

8120 GOSUB 9800 ’ calculate offset 
8130 IF OFFSET - 0 THEN RETURN 
8140 WHILE PEEK(CURRPOS*1) > 0 
8150 VARRBLE - NADDRESS + OFFSET 
8160 GOSUB 9900 * split varrble 

8170 GOSUB 8600 * store varrble 

8180 CURRPOS * VARRBLE 

8190 GOSUB 8700 * get next address 

8200 WEND 
8210 RETURN 

8600 *********************************** 

8601 * store next program line address 

8602 * at currpos and increment 

8603 * currpos 

8640 POKE CURRPOS. LOW 
8650 POKE CURRPOS*1, HIGH 
8670 RETURN 

8700 *********************************** 

8701 * get next line address from 

8702 * memory 

8703 * 

8710 LOW - PEEK(CURRPOS) 

8720 HIGH - PEEK(CURRPOS*1) 

8730 NADDRESS - HIGH * 256 + LOW 
8740 RETURN 


(continued) 


BYTE LISTINGS SUPPLEMENT 317 






May 


9800 *********************************** 

9801 * calculate offset — length 

9802 * of rem statement ( 8 bytes ) 

9803 * In the first line of 

9804 • subroutine 

9810 GOSUB 8700 * next address 
9820 OFFSET = CURRPOS + 8 - NADDRESS 
9830 RETURN 

9900 *********************************** 

9901 * split 'varrble' address or 

9902 * number for storage 

9903 ' 'variables expected* varrble 

9904 * 'variables returned* high, low 

9910 HIGH » INT(VARRBLE / 256) 

9920 LOW * VARRBLE - (256 * HIGH) 

9930 RETURN 

10000 ********************************** 

10001 * BLOAD 'routine.sub’ 

10002 ' — file found — 

10003 ' proceed to load It 

10004 * 

10010 ON ERROR GOTO 10500 ’error in open 
10020 FL$ - D$ + FLNME$ 

10030 OPEN "l\ 1, FL$ 

10040 CLOSE 
10050 RETURN 

10100 '********************************* 

10101 * BSAVE 'routIne.sub' 

10102 ' — file not found — 

10103 ' proceed to save It 

10104 ' 

10110 LLOAO - 0 
10120 RETURN 

10500 ' error in opening 'routine.sub' 

10510 IF ERR « 53 THEN RESUME 10100 

10520 PRINT "*** error in opening FL$; M ***";: • fatal 
10530 STOP 

11000 ********************************** 

11001 ' error in BSAVE or BLOAD process 

11002 ' 

11003 ' 

11020 PRINT "*** error in processing F$; " ***'•;: • fata 
11030 STOP 
11050 RETURN 

12000 '********************************* 

12001 * explanation of 'mainprog* 

12002 ' and 'routine.sub * 

12003 ' 

12010 CLS 
12020 LOCATE 1,1 
12030 COLOR 0,7 
12040 ' 

12050 LOCATE 1,57 

12060 PRINT "Date DATE$; " TIME$; 

12070 LOCATE 2,15 

12080 PRINT "A sample of a BASIC program calling a BASIC 
subroutine" 

12090 COLOR 7,0 
12110 LOCATE 5,1 

12120 PRINT"'mainprog' has been written to demonstrate a 
method we have devised 

12130 PRINT"to facilitate calling BASIC subroutines using 
Microsoft BASIC. 

12140 PRINT "" 

12150 PRINT"the modules starting at line 8000 either load 
or save a subroutine 

12160 PRINT"consisting of two modules — starting at lines 
30000 and 31000 — 

12170 PRINT"in binary, and then update consecutive line 
pointers to agree with 

12180 PRINT"the correct positions in memory " 

12190 PRINT "" 

12200 PRINT"subroutines at lines 30000 and 31000 are 
executed after they have 

12210 PRINT"been loaded into memory from thei r binary file 
'routine.bin* 
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12220 FOR I « 1 TO 2000: NEXT 
12310 RETURN 

19900 ********************************** 

19901 * position currpos to the first 

19902 * pointer to be modified prior 

19903 * to loading *routine.sub * 

19905 IF LLOAD THEN GOSUB 19985 ELSE GOSUB 29985 
19910 CURRPOS = VARPTR(F$) 

19915 LOW = PEEK(CURRP0S+1) 

19920 HIGH - PEEK(CURRPOS+2) 

19925 CURRPOS = HIGH * 256 + LOW 
19930 LOW ■ PEEK(CURRP0S+3) 

19935 HIGH = PEEK(CURRP0S+4) 

19940 CURRPOS = HIGH * 256 + LOW 
19945 RETURN 

19985 ’ set variable at end of main 

19986 • program when loading subroutine 
19990 F$ = "*" 


*********************variabIe explanation and fill area *** 
************ 

20002 • 

20004 * CURRPOS - points to the 


20005 * starting position of each 

20006 * interpreted BASIC line 

20007 * number in memory 


20008 ' LLOAD - switch to determine 

20009 • whether the subroutine is to 

20010 # be loaded into memory ( 1 ) 

20011 * or saved onto disk ( 2 ) 

20012 * OFFSET - difference in decimal 

20013 * between present subroutine 


20014 * loading position and the 


20015 # original position in memory 

20016 * when its binary version was 

20017 * saved 

20018 * NADDRESS - next line address 

20019 * to be adjusted by OFFSET 

20020 * F$ - variable used to set a 

20021 * flag in memory where the 

20022 * subroutine will be loaded 
20024 • VARRBLE - temporary storage 
20026 * FLNME$ - name of subroutine 

20028 * D$ - drive specification for 

20029 * subroutine 

20030 • 

20032 * 

20034 • 

20036 ***************************************************** 
********************* 

20040 ***************************************************** 


{ | | ******* 



*********************************************************** 
*********************************************************** 
**********' 


20045 ***************************************************** 


i I I * 


*********************************************************** 

*********** 

20050 ***************************************************** 
******************************************************fiI I* 

*********************************************************** 

*********************************************************** 

**********' 

20055 'it*************************************************** 

*********************************************************** 

*********************************************************** 

**********' 

20060 ***************************************************** 

*********************************************************** 

*********************************************************** 

**********' ( continued) 
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•**********+*+*+ m m m m 


********** 

20070 ********** 
*************** 



******************* 
r i 11* 

***************** 
******************** 

** 
i II* 

******************* 
**************** 



********************** J|{J|cl(t<M 
**********• 

29985 * sat variable at end of 
routine on disk 
29990 F$ - "*" 

29995 RETURN 


******** 

********************* 
*********************** 


main program when saving 



TEXT 

Programming Project: "Data Compression 
May, page 98. Also download hufreod.me 


with Huffman Coding," 


Jonathan Amsterdam. 



Editor’s note: Remember to break the 
before attempting to compile them. 


folowing modules into their 
Delete "======" and comments 


own files 
inside them 


Start Bitstream.DEF 


DEFINITION MODULE Bitstream; 

(* Used for bit-oriented I/O. Minimal facilities. *) 


EXPORT QUALIFIED connect, disconnect, EOS, read 
readChar, wrlteChar, readCard. writeCard 


write, 


bitStream, 


TYPE bitstream; 


uses the default drive. *) 


On a Mac, this procedure 


PROCEDURE disconnect(bs:bitStream); 

(* Disconnects stream from file. *) 

PROCEDURE EOS(bs:bitstream):BOOLEAN; 

(* TRUE at end of stream; for read streams onlyl *) 

PROCEDURE read(bs:bitStream):BOOLEAN; 

(* Reads a bit from the stream. TRUE = 1, FALSE = 0 *) 

PROCEDURE write(bs:bitStreom; b:BOOLEAN)• 

(* Writes a bit to the stream. *) 


PROCEDURE readChar(bs:bitSt ream):CHAR; 

( * ,h ~ '" ,o ° char - Th, « '• 


PROCEDURE writeChar(bs:bitSt ream 
(* Writes the character as eight 
impIementation—dependent• *) 


c:CHAR); 
consecutive 


bits. 


This is somewhat 


PROCEDURE readCard(bs:bitSt ream):CARDINAL: 

(* Reads 16 consecutive bits and translates them 


f*°wr?t RE '?T iteCa !^ bs:bitStream: c: CARD INAL 
l Writes the cardinal as 16 consecutive bit: 


Into a CARDINAL. 


*) 
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END Bitstream. 

Start BitStream.MOD 


IMPLEMENTATION MODULE Bitstream; 


(* Note: because St reams.WriteWord and St reams.ReadWord don't appear to 
work in MacModula-2, I do I/O with the character operations. A character 
code occupies bits 8-15 of a word. *) 

FROM Streams IMPORT STREAM, StreamType, Connect, Disconnect, ReadChar, 

WriteChar; 

IMPORT Streams; 

FROM Storage IMPORT ALLOCATE. DEALLOCATE; 

FROM MyTerminal IMPORT fatal; 

CONST maxBit = 15; (* highest numbered bit in a BITSET *) 

IowCharBit = 8; (* first bit of a character *) 

TYPE wordRange = [0..maxBit]; 

charRange = [IowCharBit..maxBit]; 
bitstream = POINTER TO bsRec; 
bsRec = RECORD 

stream:STREAM; 
read:BOOLEAN; 
curWord:BITSET; 
curBit rcharRange; 

END; 

PROCEDURE connect(fiIeName:ARRAY OF CHAR; read:BOOLEAN):bitStream; 

VAR bs:bitStream; 

nulIVol:ARRAY[0..0] OF CHAR; 
done:BOOLEAN; 

BEGIN 

nulIVol[0] :- 0C; 

NEW(bs); 

bs^.read :« read; 

IF read THEN 

Connect(bs^.stream, streamread, (* open stream for reading *) 

fileName, nullVol, 1, (* use drive #1 *) 

FALSE, (* don't create if nonexistent *) 

done); 

IF NOT done THEN 

fata I('cannot open file'); 


END; 

bs^.curBit :* maxBit; 

ELSE 

Connect(bs^.stream, streamwrlte, fileName, nulIVol, 1, TRUE, done); 
IF NOT done THEN 

fata I('cannot open file’); 

END; 

bs^.curBit :■ lowCharBit; 
bs A .curWord := {}; 

END; 

RETURN bs; 

END connect; 

PROCEDURE disconnects :bi tStream); 

BEGIN 

WITH bs* DO 

IF (NOT read) AND (curBlt <> lowCharBit) THEN (* flush the last word *) 
WriteChar(stream, CHAR(curWord)); 

END; 

Disconnect(stream); 

DISPOSE(bs); 

END; 

END disconnect; 




BYTE LISTINGS SUPPLEMENT 321 







M ay 


PROCEDURE EOS(bs:bitStreom):BOOLEAN: 

BEGIN 

WITH bs~ DO 
IF read THEN 

RETURN (curBit - maxBIt) AND Streams.EOS(stream): 

ELSE 

fataI(’EOS called on write bit stream'): 

END; ' 

END; 

END EOS; 

PROCEDURE read(bs:bItStream):BOOLEAN; 

wto In, Xi.Ao UrBit maxBit - curBit - "all bits to curBIt have been read" *) 
VAR c*CHAR{ 

BEGIN 

IF NOT bs*.read THEN 

fatal(’attempt to read a write bit stream’): 

ELSE WITH bs* DO 

IF curBit = maxBit THEN 

IF NOT Streams.EOS(stream) THEN 
ReadChar(stream, c); 
curWord :* BITSET(c); 
curBit := lowCharBit; 

END; 

ELSE 

INC(curBit); 

END; 

RETURN curBit IN curWord; 

END; END; 

END read; 


PROCEDURE write(bs:bitStream; b:BOOLEAN); 

(* init: curBit :« lowCharBit, curWord :■ 

curBit = "bit curBit is next to be written" *) 
BEGIN 

WITH bs* DO 
IF read THEN 

fata I(’attempt to write a read bit stream’); 

END; 

IF b THEN 

INCL(curWord, curBit); 


END; 

IF curBit = maxBit THEN 

WriteChar(stream, CHAR(curWord)); 
curWord := {}; 
curBit := lowCharBit; 

ELSE 

INC(curBit); 

END; 

END; 

END write; 

PROCEDURE readChar(bs:bitStream):CHAR; 

(* Read 8 bits and make them into a character. In MacModula-2, 

a CHAR variable is a word with bits 8-15 containing the ASCII code. *) 
VAR i:charRange; 

char:BITSET; 

BEGIN 

char := \\; 

FOR i := lowCharBit TO maxBit DO 
IF read(bs) THEN 
INCL(char, i); 

END; 

END; 

RETURN CHAR(char); 

END readChar; 

PROCEDURE writeChar(bs:bitStream; c:CHAR); 

(* see readChar for implementation details *) 

VAR i:charRange; 
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BEGIN 

FOR i := lowCharBlt TO maxBit DO 
write(bs, i IN BITSET(c)); 

END; 

END wrlteChar; 

PROCEDURE readCard(bs:bitStrearn):CARDINAL; 

VAR iiwordRange; 

card:BITSET; 

BEGIN 

FOR i := 0 TO maxBit DO 
IF read(bs) THEN 
INCL(card, i); 

ELSE 

EXCL(card, i); 

END; 

END; 

RETURN CARDINAL(card); 

END readCard; 

PROCEDURE writeCard(bs:bItStream; c:CARDINAL); 
VAR i:wordRange; 

BEGIN 

FOR I := 0 TO maxBit DO 

write(bs, i IN BITSET(c)); 


END; 

END writeCard; 
BEGIN 

END BitStream. 


Start CharStream.DEF 
DEFINITION MODULE CharStream; 

EXPORT QUALIFIED charStream, connect, disconnect, read, write, EOS; 
TYPE 

charStream; 

PROCEDURE connect(f1 IeName:ARRAY OF CHAR; read:BOOLEAN):charStream; 
PROCEDURE disconnect(cs:charStream); 

PROCEDURE read(cs:charStream):CHAR; 

PROCEDURE write(cs:charStream; crCHAR); 

PROCEDURE EOS(cs:charStrearn):BOOLEAN; 

END CharStream. 


Start CharStream.MOD 


IMPLEMENTATION MODULE CharStream; 

(* This module supports character I/O from files. Its facilities are minimal. 
I wrote it using MacModuIa-2*s Streams module; it should be easy to 
duplicate Its behavior with whatever file system you have. *) 

FROM Streams IMPORT STREAM, StreamType, Connect, Disconnect, 

ReadChar, WrlteChar; 

IMPORT Streams; 

FROM MyTerminal IMPORT fatal; 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

TYPE 

charStream ■ POINTER TO STREAM; 


( continued ) 
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PROCEDURE connect(fiIeName:ARRAY OF CHAR; read:BOOLEAN):chorStream; 

VAR cs:charStream; 

nullVol: ARRAY[0..0] OF CHAR; 
done;BOOLEAN; 

BEGIN 

nuII Vo I[0] 0C; 

NEW(cs); 

IF read THEN 

Connect(cs^, streamread, (* open stream for reading *) 

fileName, nullVol, 1, use drive jjh *) 

FALSE, (* don’t create if nonexistent *) 

done); 

IF NOT done THEN 

fata I('cannot open file'); 

END; 

ELSE 

Connect(cs~, streamwrite. fileName, nullVol, 1, TRUE, done); 

IF NOT done THEN 

fatal('cannot open file’); 

END; 

END; 

RETURN cs; 

END connect; 

PROCEDURE disconnect(cs;charStream); 

BEGIN 

Disconnect(cs~); 

DISPOSE(cs); 

END disconnect; 

PROCEDURE read(cs;charStream);CHAR; 

VAR c:CHAR; 

BEGIN 

ReadChar(cs*, c); 

RETURN c; 

END read; 

PROCEDURE write(cs:charStream; crCHAR); 

BEGIN 

Wr iteChar(cs~, c); 

END write; 

PROCEDURE EOS(cs:charStream);BOOLEAN; 

BEGIN 

RETURN St reams.EOS(cs^); 

END EOS; 

BEGIN 

END CharStream. 


Start Compress.MOD 


MODULE Compress; 

(* File compression algorithm using Huffman coding. 

Based on "Data Compression with Huffman Coding," BYTE March 1986. 
Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. 

*) 

FROM CharStream IMPORT CharStream; 

IMPORT CharStream; 

FROM Bitstream IMPORT bitstream; 

IMPORT Bitstream; 

FROM MyTerminaI IMPORT ClearScreen, pause, WriteCard, WriteLn, WriteString, 
WriteLnString, Write; 

FROM InOut IMPORT ReadString; 

FROM Huffman IMPORT huffTree, huffman, readCode, writeCode, readTree, 
writeTree, codeSize; 

FROM StringStuff IMPORT stringLen, stringCopy; 

FROM Rea IInOut IMPORT FWriteReal; 

(* FWriteReal writes real numbers in decimal format. If your implementation 
doesn't have it, substitute WriteReal. *) 
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CONST stringlen = 60; 

VAR frequency:ARRAY CHAR OF CARDINAL; 
fiIeSize:CARDINAL; 

InFileName. outFileName: ARRAY[0..stringIen] OF CHAR; 
hTree:huffTree; 


PROCEDURE doFreq; 

(* Obtain frequency count from file *) 

VAR csicharStream; 

BEGIN 

cs :* CharStream.connect(inFileName, TRUE); 
freqCount(cs); 

CharStrearn.disconnect(cs); 

END doFreq; 


PROCEDURE freqCount(cs:charSt ream); 
VAR c:CHAR; 


BEGIN 

FOR c :« 0C TO CHR(HIGH(frequency)) DO 
frequency[c] :* 0; 

END; 

c := CharStream.read(cs); 

WHILE NOT CharStream.EOS(cs) DO 
INC(f requency[c]); 

INC(fileSize); 
c :■ CharStream.read(cs); 

END; 

END freqCount; 


(* read file *) 


PROCEDURE doOutput; 

(* Output encoded file *) 
VAR inStrearn:charStream; 
outSt ream:bitStrearn; 
c:CHAR; 


InStream : = CharStream.connect(inFiIeName, TRUE); 
outStream :« BitStream.connect(outFiIeName, FALSE); 
BitStream.wr1teCard(outStream, fileSize); 
wr iteTree(outStream, hTree); 
c :* CharStream.read(inStream); 

WHILE NOT CharStream.EOS(inStream} DO 
wr iteCode(outStream, hTree, c); 
c :* CharStream.read(inStream); 

END; 

CharStream.disconnect(inStream}; 

BitStream.disconnect(outStream); 

END doOutput; 


PROCEDURE computeStats; 

(* Compute statistics on how much space was saved *) 

VAR c:CHAR; 

origBits, compBits. nChars -.CARDINAL; 
savings:REAL; 

BEGIN 

origBits :« fileSize * 8; 
compBits :■ 0; 

nChars :■ 0; 

FOR c :- 0C TO CHR(HIGH(frequency)) DO 
IF frequency[cl <> 0 THEN 
INC(nChars); 

compBits :• compBits + codeSize(hTree, c) * frequency[cJ; 

END; 

END; 

WriteStr1ng("number of different characters: "); 

WriteCard(nChars, 0); WrlteLn; 

WriteString("originaI file size (bits): "); 

WrlteCard(origBits, 0); WrlteLn; 

(continued) 
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WriteStrIng("compressed f. size (bits): "); 

Wr1teCord(compB1ts, 0); WrlteLn; 

Wr1teStr1ng("percent savings: "); 

savings 1.0 - (FLOAT(compBits) / FLOAT(or1gBIts)); 

FWriteReal(savings * 100.0, 5); WriteLn; 

Wr1teString("compressed size, Including bookkeeping: "); 

(* add 16 bits for character, count, 10n-1 bits for tree *) 

INC(compBits, 16 + 10*nChars -1); 

WriteCard(compBits, 0); WrlteLn; 

Wr1teString("true percent savings: "); 

savings :- 1.0 - (FLOAT(compBits) / FLOAT(origBits)); 

FWr1teReaI(savIngs * 100.0, 5); WrlteLn; 

END computeStats; 

PROCEDURE doOu t f1 IeName; 

(* Make the name of the output file by appending M .P" to the input file’s 
name *) 

VAR Ien:CARDINAL; 

BEGIN 


len :■ str ingLen(inFiIeName); 
str jngCopy(outFiIeName, inFiIeName); 
len] :« 
len+1] :■ 'P* 


outFiIeName 
outFiIeName 
outFiIeName 


END doOut f1 IeName; 


len+2J :« 0C; 


BEGIN 

CIearScreen; 

WriteLnString("File Compression using Huffman Coding"); 
WriteString("Input file: "); 

ReadString(InFIleName); 

doOut flIeName; 
doFreq; 

hTree :■ huffman(frequency); 
doOutput; 
computeStats; 
pause(’done—’); 

END Compress. 


Start Huffman.DEF 


DEFINITION MODULE Huffman; 

(* Implements the Huffman coding scheme and procedures for manipulating 
the code tree. *) 

FROM Bitstream IMPORT bitstream; 

EXPORT QUALIFIED huffTree, huffman, writeCode, readCode, writeTree, readTree 
codeSize; 

TYPE huffTree; 

PROCEDURE huffman(VAR frequency:ARRAY OF CARDINAL):huffTree; 

(* construct a Huffman coding tree from the given character frequencies *) 

PROCEDURE writeCode(bs:bitStream; ht:huffTree; c:CHAR); 

(* Write the code for c onto bs, using ht. *) 

PROCEDURE readCode(bs:bitStream; ht:huffTree):CHAR; 

(* Read bits from bs until a full code is read; return the character *) 

PROCEDURE writeTree(bs:bitStream; ht:huffTree); 

(* Write the tree onto the stream *) 

PROCEDURE readTree(bs:bitStream):huffTree; 

(* Read a huffTree from the stream *) 

PROCEDURE codeSize(ht:huffTree; c:CHAR):CARDINAL; 

(* returns the length of the code for c *) 

END Huffman. 
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Stort Huffman.MOO 


IMPLEMENTATION MODULE Huffman; 

(* Huffman coding algorithm, as described in "Data Compression With Huffman 
Coding," BYTE, March 1986. 

Copyright Jonathan Amsterdam 1986, All Rights Reserved. *) 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM Bitstream IMPORT bitstream; 

IMPORT Bitstream; 

FROM MyTerminol IMPORT WriteString, WriteCard, WriteLn, fatal; 

CONST maxChors = 256; 

TYPE 

node = POINTER TO nodeRec; 
nodeRec = RECORD 

char:CHAR; 
freq:CARDINAL; 

chi Id:ARRAY BOOLEAN OF node; 

parent:node; (* used for encoding *) 

END; 

huffTree = POINTER TO htRec; 
htRec - RECORD 

tree:node; (* the tree itself *) 

leaf:ARRAY CHAR OF node; (* index by character, for encoding 

*) 

END; 


VAR tree:ARRAY[1..maxChors] OF node; (* temporary list of trees *) 
nTrees -.CARDINAL; 


(*** constructing the tree ***) 


PROCEDURE Huffman(VAR frequency:ARRAY OF CARDINAL):huffTree; 

VAR ht:huffTree; 

BEGIN 

ht :* initHuffTree(frequency); 
initTrees(ht*.leaf); 

WHILE nTrees > 1 DO 

insert(combineNodes(removeSmaIlest(). removeSmallest())); 


END; 

ht*.tree tree[1]; 
RETURN ht; 

END Huffman; 


PROCEDURE initHuffTree(VAR freq;ARRAY OF CARDINAL):huffTree; 
VAR i:CARDINAL; 


ht :huf fTree; 

BEGIN 

ht :■ newHuffTree(); 

FOR i 0 TO HIGH(freq) DO 
IF freq[i] <> 0 THEN 
ht*.Ieaf[CHR(i)] :« 

END; 

END; 

RETURN ht; 

END initHuffTree; 


newNode(CHR(i), 


freq[i], NIL. NIL); 


PROCEDURE in1tTrees(VAR Ieaf:ARRAY OF node); 

VAR i:CARDINAL; 

BEGIN 

nTrees := 0; 

FOR i 0 TO HIGH(leaf) DO 
IF Ieaf[i] <> NIL THEN 
Insert(Ieaf[i]); 

END; 

END; 

END initTrees; 

[continued] 
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PROCEDURE removeSmaI Iest()mode; 

VAR i, smaI lest:CARDINAL; 

sma I I estNode mode; 

BEGIN 

smaI Iest :■ 1; 

FOR i 2 TO nTrees DO 

IF tree[i]".freq < tree[smallest]".freq THEN 
smaI Iest :* I; 

END; 

END; 

smallestNode :® tree[smaI Iest1; 
tree[smaI Iest] ;■ treefnTrees]; 

DEC(nTrees); 

RETURN smallestNode; 

END removeSmaI Iest; 

PROCEDURE Insert(nmode); 

BEGIN 

INC(nTrees); 

tree[nTrees] := n; 

END insert; 


(*** code I/O ***) 

PROCEDURE writeCode(bs:bitStream; ht:huffTree; c:CHAR); 

(* Write the code for c onto bs, using ht. By using recursion, we can 
avoid explicitly retracing the path from the root to the leaf. *) 

PROCEDURE wrCode(nmode); 

BEGIN 

IF n".parent <> NIL THEN 
wrCode(n".parent); 

BitStream.write(bs, n ■ n".parent",chiId[TRUEl); 

END; 

END wrCode; 

BEGIN 

IF ht".leaf[c] - NIL THEN 

WriteString("no code for "); WriteCard(CARDINAL(c), 0); WriteLn; 
fatal('dying*); 

END; 

wrCode(ht".leaf[c]); 

END wr1teCode; 

PROCEDURE readCode(bs:bitStream; ht:huffTree):CHAR; 

(* Read bits from bs until a full code is read; return the character *) 

PROCEDURE rdCode(n:node):CHAR; 

BEGIN 

IF leaf(n) THEN 

RETURN n".char; 

ELSE 

RETURN rdCode(n".chiId[BItStream.read(bs)1); 

END; 

END rdCode; 

BEGIN 

RETURN rdCode(ht".tree); 

END readCode; 

PROCEDURE writeTree(bs:bitStream; ht:huffTree); 

(* Write the tree onto the stream. It is encoded as follows: 

A 1 bit indicates an internal node. 

A 0 bit indicates a leaf; the next 8 bits are the character code. 

The tree is traversed by preorder traversal: first the root, then 
the left (FALSE) subtree, then the right (TRUE). *) 

PROCEDURE wrTree(nmode); 

BEGIN 

IF leaf(n) THEN 

Bitstream.write(bs, FALSE); 

BitStream.writeChar(bs, n".char); 
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ELSE 

BitStream.write(bs, TRUE); 
wrTree(n*.child[FALSEl); 
wrTree(n*.child[TRUE]); 

END; 

END wrTree; 

BEGIN 

wrTree(ht*.tree); 

END writeTree; 

PROCEDURE readTree(bs:bitStream):huffTree; 

(* Read a huffTree from the stream. See writeTree for the encoding used. 

Frequency information is NOT preserved. *) 

VAR ht:huffTree; 

PROCEDURE rdTree()inode; 

VAR false, true, n:node; 

BEGIN 

IF Bitstream.read(bs) THEN (* an internal node *) 
false := rdTree(); 
true := rdTree(); 
n := newNode(0C, 0, false, true); 
fa Ise A .parent :* n; 
true*.parent ;■ n; 

RETURN n; 

ELSE (* a leaf *) 

n := newNode(BitStream.readChar(bs), 0, NIL, NIL); 
ht*.Ieaf[n*.char] := n; 

RETURN n; 

END; 

END rdTree; 

BEGIN 

ht :* newHuffTree(); 
ht*.tree :■ rdTree(); 

RETURN ht; 

END readTree; 


(*** huffTree allocation ***) 

PROCEDURE newHuffTree():huffTree; 

VAR c:CHAR; 

ht ;huffTree; 

BEGIN 

NEW(ht); 

FOR c := 0C TO CHR(HIGH(ht^.leaf)) DO 
ht*.Ieaf[c] := NIL; 

END; 

RETURN ht; 

END newHuffTree; 

(*** node stuff ***) 

PROCEDURE combineNodes(n1, n2:node):node; 

(* used to combine nodes when constructing the coding tree *) 

VAR ninode; 

BEGIN 

n newNode(0C, n1*.freq + n2*.freq, nl, n2); 
nl*.parent :* n; 
n2*.parent :>= n; 

RETURN n; 

END combineNodes; 

PROCEDURE newNode(c:CHAR; f:CARDINAL; false, true:node):node; 

VAR ninode; 

BEGIN 

NEW(n); 

WITH n* DO 

char :« c; 
freq :» f; 

chi Id[FALSE] :» false; 

[continued) 
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ch1I d[TRUE] true; 
parent :* NIL; 

END; 

RETURN n; 

END newNode; 

PROCEDURE freeNode(nmode); 

(* In the current implementation, this is never used *) 
BEGIN 

IF n <> NIL THEN 

freeNode(n^.chIld[FALSEl); 
freeNode(n*.child[TRUE]); 

DISPOSE(n); 

END; 

END freeNode; 

PROCEDURE Ieaf(n:node):BOOLEAN; 

BEGIN 

IF n = NIL THEN 

fatal(* Ieaf: n NIL*); 

END; 

RETURN n^.child[FALSE] - NIL; 

END leaf; 

PROCEDURE codeSize(ht:huffTree; c:CHAR):CARDINAL; 

(* returns the length of the code for c *) 

VAR i:CARDINAL; 

nrnode; 

BEGIN 

i :« 0; 

n :** ht~. I eaf [c] ; 

WHILE n <> NIL DO 
INC(i); 

n :» n~.parent; 

END; 

RETURN 1-1; 

END codeSize; 

BEGIN 

END Huffman. 


Start MyTerminaI.DEF 


DEFINITION MODULE MyTerminal; 

(* Some small but useful additions to the Terminal module. *) 

EXPORT QUALIFIED WriteString, WriteLn, Write, Read, ClearScreen, Beep, 

WriteLnString, Writelnt, WriteCard, pause, fatal; 

PROCEDURE WriteString(s:ARRAY OF CHAR); 

PROCEDURE WriteLn; 

PROCEDURE W rit e(c:CHAR); 

PROCEDURE Read(VAR c:CHAR); 

PROCEDURE ClearScreen; 

PROCEDURE Beep; 

PROCEDURE WriteLnString(s:ARRAY OF CHAR); 

PROCEDURE Writelnt(l:INTEGER; spacesrCARDINAL); 

PROCEDURE WriteCard(c, spaces CARDINAL); 

PROCEDURE pause(msg:ARRAY OF CHAR); 

(* Prevents the screen from blanking and returning to the Finder until the 
user hits a key. msg is typed out. *) 

PROCEDURE fatal(msg:ARRAY OF CHAR); 

(* Prints the message, does a pause, and HALTs. *) 

END MyTerminaI. 
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Start MyTerminaI.MOD 
IMPLEMENTATION MODULE MyTerminal; 

(* Some small but useful additions to the Terminal module. *) 
IMPORT TerminaI; 

VAR powerOfTen: ARRAY[0..4] OF CARDINAL; 


PROCEDURE WriteLnString(s:ARRAY OF CHAR); 

BEGIN 

Terminal.WriteString(s); 

TerminaI.WriteLn; 

END WriteLnString; 

PROCEDURE Wr i telnt ( i : INTEGER; spaces -.CARDINAL) ; 

BEGIN 

IF i < 0 THEN 

writeNum(CARDINAL(-i), spaces-1, TRUE); 

ELSE 

writeNum(CARDINAL(i), spaces, FALSE); 

END; 

END Writelnt; 

PROCEDURE WriteCard(c, spaces:CARDINAL); 

BEGIN 

writeNum(c, spaces, FALSE); 

END WriteCard; 

PROCEDURE writeNum(c, spaces:CARDINAL; neg:BOOLEAN); 

VAR p:CARDINAL; 

i:INTEGER; 

BEGIN 

p := places(c); 

FOR i 1 TO INTEGER(spaces) - INTEGER(p) DO 
TerminaI.Write(* *) ; 

END; 

IF neg THEN 

TerminaI.Write(); 

END; 

FOR i p-1 TO 0 BY -1 DO 

Terminal.Write(CHR((c DIV powerOfTen[i]) + ORD( , 0 , )))l 
c :* c MOD powerOfTen[i]; 

END; 

END writeNum; 

PROCEDURE pI aces(c:CARDINAL):CARDINAL; 

(* Returns the number of places c takes to print; i.e. trunc(1+log10(c)). *) 
VAR i:CARDINAL; 

BEGIN 

FOR i :*= 4 TO 0 BY -1 DO 

IF (c DIV powerOfTen[i]) > 0 THEN 
RETURN i+1; 

END; 

END; 

RETURN 1; 

END places; 


PROCEDURE pause(msg:ARRAY OF CHAR); 

(* Prevents the screen from blanking and returning to the Finder until the 
user hits a key. msg is typed out. *) 

VAR ch:CHAR; 

BEGIN 

Terminal.WriteString(msg); 

TerminaI.Read(ch); 

END pause; 

PROCEDURE fatal(msg:ARRAY OF CHAR); 

(continued) 
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BEGIN 

Wr I teLnStrIng(msg); 
pause(’Hlt any key to die—*); 
HALT; 

END fatal; 


(*** Copies of Terminal procedures ***) 

PROCEDURE WrlteString(s:ARRAY OF CHAR); 

BEGIN 

Terminal.WrlteString(s); 

END WriteString; 

PROCEDURE WriteLn; 

BEGIN 

Term!naI.WriteLn; 

END WriteLn; 

PROCEDURE Wrlte(c:CHAR); 

BEGIN 

TerminaI.Write(c); 

END Write; 

PROCEDURE Read(VAR c:CHAR); 

BEGIN 

TerminaI.Read(c); 

END Read; 

PROCEDURE ClearScreen; 

BEGIN 

TerminaI.Cl earScreen; 

END ClearScreen; 

PROCEDURE Beep; 

BEGIN 

TerminaI.Beep; 

END Beep; 

BEGIN 


powerOfTen 

’0' 

:* 1; 

powerOfTen 

Y 

:« 10; 

powerOfTen 

2' 

100; 

powerOfTen 

3 

1000; 

powerOfTen 

V 

;« 10000; 


END MyTerminaI. 


Start StringStuff.DEF 
DEFINITION MODULE StringStuff; 

EXPORT QUALIFIED stringCap, charCap, stringLen, stringCopy, stringEqual 
PROCEDURE charCap(ch:CHAR):CHAR; 

PROCEDURE stringCap(VAR s:ARRAY OF CHAR); 

PROCEDURE str i ngLen(VAR s ; ARRAY OF CHAR)-.CARDINAL; 

PROCEDURE stringCopy(VAR s1:ARRAY OF CHAR; s2:ARRAY OF CHAR); 

PROCEDURE stringEqual(si, s2;ARRAY OF CHAR):BOOLEAN; 

END StringStuff. 

Start StringStuff.MOD 


IMPLEMENTATION MODULE StringStuff; 


332 BYTE LISTINGS SUPPLEMENT 






M ay 


PROCEDURE chorCop(ch:CHAR):CHAR; 

BEGIN 

IF (ch >- 'o’) AND (ch <- 'z') THEN 
RETURN CAP(ch); 

ELSE 

RETURN ch; 

END; 

END charCap; 

PROCEDURE strIngCap(VAR s:ARRAY OF CHAR); 

VAR I:CARDINAL; 

BEGIN 

FOR i :« 0 TO stringLen(s) DO 
s[I] charCap(s[i]); 

END; 

END stringCap; 

PROCEDURE stringLen(VAR s:ARRAY OF CHAR):CARDINAL; 

VAR i:CARDINAL; 

BEGIN 

FOR i := 0 TO HIGH(s) DO 
IF s[i] = 0C THEN 
RETURN i; 

END; 

END; 

RETURN HIGH(s)+1; 

END stringLen; 

PROCEDURE stringCopy(VAR s1:ARRAY OF CHAR; s2:ARRAY OF CHAR); 
VAR i:CARDINAL; 

BEGIN 

i 0; 

LOOP 

IF i > HIGH(sl) THEN 
EXIT; 

ELSIF i > HIGH(s2) THEN 
sl[i] :« 0C; 

EXIT; 

ELSE 

s 1 [ i ] s2[i]; 

END; 

INC(i); 

END; 

END stringCopy; 

PROCEDURE strIngEqual(si, s2:ARRAY OF CHAR):BOOLEAN; 

VAR I;CARDINAL; 

BEGIN 

FOR I 0 TO HIGH(sl) DO 
IF i > HIGH(s2) THEN 
RETURN s1[i] - 0C; 

ELSIF s 1 [ 1 ] <> s2[i] THEN 
RETURN FALSE; 

ELSIF sl[i] = 0C THEN 
RETURN TRUE; 

END; 

END; 

RETURN TRUE; 

END strIngEqua I ; 


BEGIN 

END StringStuff. 


Start Uncompress.MOD 


MODULE Uncompress; 

(* Takes files encoded by Compress and restores them to their original 
state. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *) 

( continued ) 
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FROM CharStream IMPORT charStream; 

IMPORT CharStream; 

FROM Bitstream IMPORT bitstream; 

IMPORT Bitstream; 

FROM MyTerminaI IMPORT ClearScreen, pause, WriteCard, WriteLn, WriteString, 
WrIteLnString, Write; 

FROM InOut IMPORT ReadString; 

FROM Huffman IMPORT huffTree, huffman, readCode, readTree; 

FROM StringStuff IMPORT strlngLen, stringCopy; 

CONST stringlen - 60; 

VAR inFileName, outFileName: ARRAY[0..stringIen] OF CHAR; 

PROCEDURE doUncompress; 

VAR InStreamibitStream; 
outStrearn;charStream; 

fileSize, i;CARDINAL; (* number of characters in file *) 
hTreeihuffTree; 

BEGIN 

inStream :* BitStream.connect(inFiieName, TRUE); 
outStream := CharStream.connect(outFiIeName, FALSE); 
fileSize :■ BitStream.readCard(inStream); 
hTree :■ readTree(inStream); 

FOR i := 1 TO fileSize DO 

CharStream.write(outStream, readCode(inStream, hTree)); 

END; 

CharStream.disconnect(outStream); 

Bi tStream.disconnect(inStream); 

END doUncompress; 


PROCEDURE doFileNames; 

VAR Ien;CARDINAL; 

BEGIN 

len := stringLen(inFiIeName); 
strIngCopy(outFiIeName, inFiIeName); 


END 


inFiIeName 
InFiIeName 
inFiIeName 
outFiIeName 
outFiIeName 
outFiIeName 
doFiIeNames 


I en] 
len+ll : 
len+2] : 
“len] :■ 
len+1] 
len+2J 


*P*; 
0C; 

» * • 

= 'U’; 
= 0C; 


BEGIN 

ClearScreen; 

WriteLnString("Uncompress ion program"); 

WriteString(' Input file (omit ".P"): '); 

ReadSt ring(inFiIeName); 

doFiIeNames; 

doUncompress; 

pause('done—•); 

END Uncompress. 


hufread.me 
TEXT 

Programming Project; "Data Compression with Huffman Coding," Jonathan Amsterdam. 
May, page 98. Also download huffman.bix. 


This is the Modula-2 source code accompanying Jonathan Amsterdam's article 
"Data Compression with Huffman Coding" in May BYTE 1986. This code was 
developed under MacModula-2 for the Mac but should be easy to convert to 
other Modula-2 compilers. Because the Mac allows character names longer than 
eight, the modules have been concatenated into one file with comments 
separating the different modules. You should break these modules out into 
their own file before attempting to compile them. 
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opticdb.c 
TEXT 

"The Application Interface of Optical Drives," by Jeffrey R. Dulude. 
May, page 193. 


A Write Once Corporate Personnel Database 


Purpose 

The purpose of this database is to provide an example of how a write once 
application could be developed. Code is provided only to the point of 
being followable for concept explanation and development. Some of the 
functions are available from the Optotech "C" interface library which 
runs on the Optotech 200 Megabyte/side write once optical disk. 


Concepts 


Several concepts are used here: 

space is cheap — there’s no need to throw old data away. In fact, it 
is required to be kept in this application 
records occupy one or more full sectors — the write once aspect of 

optical disks requires that every sector used is a full sector, 
partial sectors cannot be written to and then added to at a later 
time. So we use full sector records, even if it means adding filler 
at the end of our data fields, 
post fields — allow us to update with write once media 
post fields — allow us an "audit trail" back to previous revisions of 
data 


struct 

keytag j 



A 


char value[20J; 

A 


struct *keytag left; 

A 


struct *keytag right; 

I ; 

A 

struct 

uptag { 



A 


long recnum; 


A 


long dateti 

i ; 

me; 


A 

struct 

curtag { 



A 


long recnum; 


A 


int updates; 


A 


char *recbody; 

) 

A 


char *prevrec; 


A 


char ^search; 


A 


struct uptag[MAXVERS]; 

A 

long Totrecs; 



A 

long Curecnm; 



A 

struct 

Currec; 



A 

int Ofd; 



A 

int Ufd; 



A 

int Kfd; 



A 

struct 

emplytag \ 



A 


long date; 




char Iname 

20 

» 

A 


char fname 

‘20 

» 

A 


char mname 

‘20 

» 

A 


char socsec[8 

• 

A 


char addressl 

201; 

A 


char address2 

.20]; 

A 


char city[20] 
char state[2] 

» 

9 

A 

A 


structure describing the self-so 
the key word */ 

the left child of the tree */ 
the right child of the tree */ 


stucture describing each level o 
record number */ 

date and time */ 


stucture describing the current 


record number */ 

number of updates made */ 

pointer to the latest data */ 

pointer to a previous version 
current search criteria */ 

list of updates */ 

total records in database */ 


current record being worked on 
current record being worked on 

the original data records file 


the updates 

file 

V 

the keyword 

file 

*/ 

date of this 

entry 

*/ 

last name 

*/ 


first name 

*/ 


middle name 

*/ 



social security number */ 

address Iine 1 */ 

address I Ine 2 */ 

city */ 

state */ 


ting key list */ 

update */ 

ecord */ 

*/ 

*/ 

*/ 

*/ 
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*/ 


char zip[9]; /* zip code */ 

char teIephone[12]; 


char birthpl[40]; 
char sex; 
char spousnm[40]; 
char beneficl[401; 
char benefIc2[40]; 
char t i 11e[15J; 

Int I eve I; 

Int dept; 
long salary; 

long hiredate; 
char f i I Ier[to make 


/* place of birth */ 

/* name of spouse */ 

/* primary beneficiary */ 

/* secondary beneficiary */ 

/* job title / position */ 

/* pay level / job grade */ 

/* department */ 

/* current salary */ 

/* employment progression history 
/* hiring date */ 

512 bytes]; 


*/ 


/* assumed functions */ 

/* oopen, oclose, oread, owrite, and olseek work just like their magnetic */ 

/* stdio counterparts */ 

/* available from the Optotech Optical Drive Toolkit for PC-DOS */ 

/* Optotech, 303-570-7500 */ 


int oopen(fname, mode) 

int oclose(fd) 

int oread(fd, buf, len) 

int owrlte(fd, buf, len) 

long olseek(fd, pos, mode) 


long curdttmQ; 
int getentryfbuffer) 
int chgentry(buffer) 

Int owrltep(fd, record, value) 

int oreadp(fd, record, &value) 

updtree(root, record, number) 


long keymatch(root, string) 


int getkey(keystr) 
int displayf) 

Int disprec(record) 
int abort(msg) 
int menu() 

report() 


/* opens file "fname" in mode on optical disk */ 
/* returns file descriptor */ 

/* valid mode are 0, 1, and append (2) */ 

/* closes file fd previously oopened */ 

/* reads len bytes into buf from fd, returns */ 
/* number of bytes read */ 

/* writes len bytes into buf from fd, returns */ 
/* number of bytes written */ 

/* seeks to pos in file fd based on mode */ 

/* mode ** 0, from beginning */ 

/* mode == 1, from current position */ 

/* mode == 2, from end */ 

/* returns current date and time */ 

/* gets a record and puts it in buffer */ 

/* takes the record in buffer, collects changes */ 
/* to it, then returns the modified buffer */ 

/* writes the post field of record of file fd */ 
/* with the location stored in value */ 

/* reads the post field of record of file fd */ 
/* and fills value with the location*/ 

/* adds values to the binary key tree starting */ 
/* node root, uses number as the reference */ 

/* location back into the data files */ 

/* tries to find a match in the key tree for */ 

/* string, returning the record number if */ 

/* successful */ 

/* gets a search key and puts it into keystr */ 
/* an error display routine */ 

/* displays a record */ 

/* displays msg then exits to OS */ 

/* displays a list of choices and returns with */ 
/* selection number */ 

/* runs a report generator */ 


addentry() 

char record[RECSIZE]; 

rtn = getentry(record); 
if(lrtn) 

return 0; 

else { 

add(record); 
return 1; 


updateQ 
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/* get the data */ 

rtn ■ chgentry(Currec.recbody); 

/* set up the new data fields */ 
newrec » (struct *empltag) Currec.recbody; 
newrec->date = curdttm(); 

/* new find out where this record will go in the update file */ 
recnum = olseek(Ufd, 0L, 2)/RECSIZE; 

/* put it there */ 
owrite(Ufd, newrec, RECSIZE); 

/* now, write the previous "latest record's" postfield with */ 
/* the location (record number) of our recent update */ 

/* write it in the original file if it's the first update */ 

if(Currec.updates > 0) 

owritep(Ufd, recnum, Currec.uptagfupdates].recnum); 

e I se 

owritep(Ofd, recnum, Currec.recnum); 

/* now, update the Currec structure */ 

Currec.updates++; 

Currec.updata[Currec.updates].recnum = recnum; 

Currec.updata[Currec.updates].datetime * curdttm(); 
return 1; 




getrecr(recnum) /* gets a relative record */ 

long recnum; 


Currec.updates ■ 0; 

/* seek to and get the original record */ 
olseek(Ofd, recnum*RECSIZE, 0); 
oread(Ofd, Currec.recbody, RECSIZE); 

/* now follow the update chain */ 
postfld * oreadp(Ofd, recnum, &postval); 
whiIe(postfId) j 

/* go to the new data and read it in */ 
oI seek(Ufd, postfId*RECSIZE, 0); 
oread(Ufd, Currec.recbody, RECSIZE); 

/* now update Currec's update list */ 

Currec.updata[Currec.updates].recnum = postval; 
temp * (struct *empltag) Currec.recbody; 

Currec.updata[Currec.updates].datetime * temp.date; 
Currec.updates++; 

/* now, see if there’s another one */ 

postfld * oreadp(Ufd, postvaI*RECSIZE, fcpostval); 


Curecnm - recnum; 
return 1; 




getoId(I eve I) 
int level; 

i 


/* gets a previous revision of the current record */ 

/* and puts It In Currec.prevrec */ 


oI seek(Ufd, Currec.updata[I eve I].recnum * RECSIZE, 0); 
oread(Ufd, Currec.prevrec, RECSIZE); 


\ 


getrevs() 


/* returns the number of revisions of current record */ 


[continued) 
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/* position at the first record */ 


getrecr(0L); 


i 

aoend() /* position at the last record */ 


getrecr(Totrecs - 1L); 

I 

aetnext() 


/* get the next relative record */ 


if(Curecnm + 1L < Totrecs) { 

getrecr(Curecnm + 1L); 
return 1; 

! else 

return 0; 


\ 


etprevQ 


/* get the previous relative record 


if(Curecnm - 1L >■ 0) { 

getrecr(Curecnm - 1L); 
return 1; 

\ else 

return 0; 


\ 

add(record) /* add a record to the database */ 

char ^record; 

I 

/* go to th end of the data base /* 

recnum - olseek(Ofd, 0L, 2); 

/* now write the data */ 
owrite(Ofd, record, RECSIZE); 

/* now update the binary key tree with keywords and record number */ 

updtree(Treeroot, record, recnum); 

Totrecs++; 


I 

long findkey(keystr) /* do a key search and return record */ 

char *keystr; 

i 


matchrec = keymatch(Treeroot, keystr); 

if(matchrec «« -1L) 
return -1L; 

else { 

/* get the record and return its value */ 
getrecr(matchrec); 
return(matchrec); 


I 

search() /* search the database for a key match */ 

\ 
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getkey(keystr); 

rtn « findkey(keystr); 

/* depending on result, display error or record */ 
i f(rtn == -1L) 

display( M No match found"); 

e I se 

disprec(rtn); 


* 

startup() /* perform database initialization */ 


/* open the database files to allow for additions 
Ofd « oopen("1:original.dat", OAPPEND); 
if (Ofd == -1) \ 

abort("CouIdn't open data file"); 


Ufd * oopen("1rupdate.dat", OAPPEND); 
if (Ufd =* -1) { 

oclose(Ofd); 

abort("CouIdn't open update file"); 


Kfd = oopen("1:keyfIle.dat", OAPPEND); 
if (Kfd == -1) { 

oclose(Ofd); 
oclose(Ufd); 

abort("Couldn*t open key file"); 


/★ set total record number */ 

Totrecs = olseek(Ofd, 0L, 2)/RECSI2E; 

/* and ao to the first record */ 
gozero(); 


I 


quit() 


oclosefOfdh 
oclose(Ufd); 
oclose(Kfd); 




*/ 


mainmenu() 


startup(); 

while(l) { 

switch(menu()) j 
case 1: 

addentry(); 
break; 

case 2: 

updote(); 
break; 

case 3: 

search(); 
break; 

case 4: 

r«port(); 
break; 

case 5: 

quitQ; 
break; 


{continued) 
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error("Not a valid entry, try again"); 
break; 




pell.bas 
TEXT 

Mathematical Recreations: "The Pel I Ian Equation," Robert T. Kurosaka. 
May, page 379. 


10 **************************************** 

20 ’* PELLIAN EQUATION * 

30 X"2 - D*Y~2 - 1 * 

40 § * BY BOB KUROSAKA * 

50 **************************************** 

60 REM ENTER A NONSQUARE INTEGER D. THE PROGRAM 
70 REM DETERMINES THE FIRST (LEAST) SOLUTION, THE 
80 REM RECURSIVE FORMULAS, AND THE 2ND SOLUTION. 

90 REM 
100 REM 
110 CLS 

120 DIM P(100),Q(100),A(100) 'Hope 100 is enough! 

130 INPUT "D = ";D 
140 D=ABS(INT(D)) 

150 RD=VAL(STR$(SQR(D))) ’Remove guard digits from SQR(D) 

160 IF RDoINT(RD) THEN 180 

170 PRINT “D must not be a square!":GOTO 130 

180 ’ 

19 0 ’-FIRST HALF: FIND As- 

200 * 

210 P(1)=0:Q(1)=1:A(1)«INT(SQR(D)):N=1 ’1ST COLUMN VALUES 
220 N-N+1 

230 P(N)»A(N-1)*Q(N-1)-P(N-1) 

240 Q(N)=(D-P(N)*P(N))/Q(N-1) 

250 A(N)=INT((A(1)+P(N))/Q(N)) 

260 IF A(N)=2*A(1) THEN 290 
270 GOTO 220 


280 ’ 

290 *-SECOND HALF: FIND X0 AND Y0- 

300 * 

310 CL-N-1 ’CL-CYCLE LENGTH 


312 FOR I=N+1 TO 2*CL ’REPEAT CYCLE 

314 A(I)=A(I-CL): "(I)=P(I-CL): Q(I)=Q(I-CL) 

316 NEXT I 

320 IF CL/2<>INT(.JL/2) THEN CL=2*CL 
330 DIM X(CL), Y(CL) 

340 * 

350 •-FIND Xs AND Ys- 

360 ’ 

370 X(1)-A(1):Y(1)«1 'SET UP 1ST 2 COLUMNS 

380 X(2)=A(1)*A(2)+1:Y(2)=A(2) * OF Xs AND Ys 

390 IF CL<3 THEN 450 

400 FOR 1=3 TO CL 

410 X(I)=A(I)*X(I-1)+X(I-2) 

420 Y(I)=A(I)*Y(I-1)+Y(I-2) 

430 NEXT I 
440 * 

450 •-FIRST SOLUTION- 

460 * 

470 X0=X(CL):Y0=Y(CL):C=2*X0 ’(X0,Y0) = LEAST SOLUTION 

480 PRINT:PRINT "LEAST SOLUTION: " 

490 PRINT “X = ”;X0 
500 PRINT "Y = ”:Y0 
510 ’ 

520 •-PRINT RECURSIVE FORMULAS- 

530 * 

540 PRINT:PRINT "FORMULAS: " 

550 PRINT ”X(N) = ";C;"* X(N-1) - X(N-2)" 

560 PRINT ”Y(N) = ";C;"* Y(N-1) - Y(N-2)" 
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570 • 

580 * *-CHECK X0 AND Y0- 

590 ’ 

600 PRINT:PRINT "CHECK:” 

610 L-LEN(STR$(D)) 

620 PRINT TA8(L+3)"X~2 . ";X0*X0 
630 PRINT D;"* Y A 2 - ";D*Y0*Y0 
640 ’ 

650 ’-PRINT 2ND SOLUTION- 

660 * 

670 PRINT:PRINT "SECOND SOLUTION; » 

680 PRINT "X - ";C*X0-1;" Y - ";C*Y0 
690 END 


rout me.sub 
TEXT 

Programming Insight: "Subroutine Overlays in GW-BASIC," Mike Carmichael. 
May, page 151. Also download mainprog.bas. 


30000 

30001 

30002 

30003 

30004 

30005 

30006 

30008 

30009 

30010 
30020 
30030 
30040 

31000 

31001 

31002 

31003 

31004 
31010 
31020 
31030 


************************************************************************** 

* routine.sub 

* subroutine #1 

Note: first line must consist of only line # and one * REM* statement 
Also, when saving or loading the binary version, * routine.sub* 
must be placed at the end of ’mainprog’ 

■ ************************************************************************* 
CLS 

GOSUB 12000: * heading again for the fun of It 
LOCATE 16,20: PRINT "subroutine #1"; 

RETURN 

* ************************************************************************* 
' subroutine #2 


LOCATE 17,20: PRINT "subroutine #2"; 

LOCATE 18,20: PRINT "returning to main program"; 
RETURN 


/ 


/ 


\ 
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indexbpp.1st 
TEXT 

Programming Project: "A Simple File-Indexing System," by Bruce Webster. 
June, page 92. Also download indexbpp.pas. 


const 

IndexMax 

= 1000; 

RecCountErr 

- -2; 

NewF11eCreated 

■ -1; 

NoError 

= 0; 

RecordNotFound 

- 1; 

NoMoreRoom 

* 2; 

AlreadyExists 

= 3; 

OutOfRange 

= 4; 

type 

Keytype = 

string[40l; 

FileStr 

str ing[80J; 

DataRec « record 

case Boolean 

of 

True : 

(NumRecs : Integer); 

False : 

(Key : Keytype; 

theRest : Whatever; 

{ this represents the rest of your data f 

end; 

IndexRec ■ record 

Key ; 

Keytype; 

Num : 

Integer 

end; 

IndexList 

array[1..IndexMax] of IndexRec 

var 

KList : 

IndexList; 

DFMe 

file of DataRec; 

MaxRec : 

Integer; 


LISTING 1. Global definitions and declarations. 


compiler-specific file I/O routines } 

| these procedures are specific to TURBO Pascal. If you 

are using another Pascal compiler, you will need to 
modify them appropriately. Note that TURBO Pascal does 
not support the standard routines GET and PUT, but instead 
uses READ and WRITE. ( 

{$I-f { turn off I/O error checking \ 

procedure FRead(RNum : Integer; var Rec ; DataRec; var Error : Integer); 
reads record #RNum Into Rec 

beg i n 

If (RNum < 0) or (RNum > MaxRec) 
then Error OutOfRange 
else begin 

Seek(DFIle.RNum); 

Error :■ IOResult; 

If Error ■ NoError then begin 
Read(DFile.Rec); 

Error IOResult 


( continued ) 
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end; 

If Error > 0 

then Error 100 + Error 

end 

end; j of proc FRead } 


procedure FWrlt«(RNum : Integer; Rec : DatoRec; var Error : Integer 

j writes record #RNum into Rec 

begin 

if (RNum < 0) or (RNum > MaxRec) 
then Error :* OutOfRange 
eIse begin 

Seek(DFI Ie,RNum); 

Error :« IOResult; 
if Error =» NoError then begin 
Write(DFile.Rec); 

Error :* IOResult 
end; 

I f Error > 0 

then Error :*= 100 + Error 
end 

end; | of proc FRead } 


procedure FOpen(FIIeNome : FlleStr; vor Error : Integer); 


*° ° pen F,leNom ®: it doesn't exist, creates 

it with the appropriate header record 


const 

TurboNoFIIe - 1; J "no file" error code for TURBO Pascal 

var 

IOCode ; Integer; 

TRec ; DatoRec; 

beg i n 


Assign(DFile.FileName); 

Reset(DFlie); 

IOCode :* IOResult; 
if IOCode * TurboNoFile then begin 
FiII Char(TRec,S1zeOf(TRec), 0 ); 
RewrIte(DFile); 

TRec.NumRecs ;■ 0; 

FWrite(0,TRec,Error); 
Close(DFile); 

Assign(DF1 Ie,F \ Iename); 

Reset(DFile); 

IOCode := IOResult; 
if IOCode * NoError 
then Error := NewFiIeCreated 

end; 

If IOCode <> NoError 
then Error := 100 + IOCode; 
end; j of proc FOpen \ 


file doesn*t exist } 


\ 


procedure FCIose(var Error : 

^ cIoses file 

beg i n 

Close(DFile); 

Error := IOResult; 

I f Error > 0 

then Error := Error + 100 
end; { of proc FCIose | 


Integer); 


|$I+j | turn on I/O error checking } 


LISTING 2a. File I/O routines specific to TURBO Pascal. 


compiler-specific file I/O routines 
i these procedures are specific to UCSD Pascal. If you 

are using another Pascal compiler, you will need to 
modify them appropriately. 
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{$1-} { turn off I/O error checking \ 

procedure FRead(RNum : Integer; var Rec : DataRec; var Error ; Integer); 
reads record #RNum into Rec 

begin 

if (RNum < 0) or (RNum > MaxRec) 
then Error :« OutOfRange 
else begin 

Seek(DFiIe,RNum); 

Error IOResult; 
if Error * NoError then begin 
Get(DFiIe); 

Error := IOResult; 
if Error = NoError 
then Rec := DFiIe~ 

end; 

if Error <> NoError 

then Error := 100 + Error 

end 

end; { of proc FRead \ 

procedure FWrite(RNum ; Integer; Rec : DataRec; var Error : Integer); 
writes record #RNum into Rec 

beg i n 

if (RNum < 0) or (RNum > MaxRec) 
then Error := OutOfRange 
else begin 

Seek(DF?le.RNum); 

Error :■ IOResult; 
if Error ■ NoError then begin 
DFi Ie~ Rec; 

Put(DFlie); 

Error :■ IOResult 
end; 

if Error > 0 

then Error := 100 + Error 

end 

end; { of proc FRead } 

procedure FOpen(F1 IeName : FileStr; var Error : Integer); 

tries to open FileName; if it doesn’t exist, creates 
it with the appropriate header record 

\ 

const 

UCSDNoFile - 1; { “no file" error code for UCSD Pascal \ 

var 

IOCode : Integer; 

TRec : DataRec; 

beg i n 

Reset(DF1 Ie,FiIeName); 

IOCode :« IOResult; 

if IOCode = UCSDNoFile then begin \ file doesn’t exist } 

FiI IChar(TRec,SizeOf(TRec),Chr(0)); 

Rewr1te(DFiIe,F1 IeName); 

TRec.NumRecs 0; 

FWrite(0,TRec,Error); 

CIose(DFiIe,Lock); 

Reset(DFile,FileName); 

IOCode :■ IOResult; 

If IOCode - NoError 

then Error :■ NewFiIeCreated 

end; 

if IOCode <> NoError 
then Error 100 + IOCode; 
end; { of proc FOpen } 

procedure FCIose(var Error : Integer); 

closes file 

i 


[continued) 
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beg i n 

Close(DFile.Lock); 

Error :■ IOResult; 
if Error > 0 

then Error :« Error + 100 
end; j of proc FCIose ( 

{$I+| { turn on I/O error checking \ 

LISTING 2b. File I/O routines specific to UCSD Pascal. 


procedure SortIndexList; 

sorts the array KLlst using a selection sort technique 
var 

I.J.MIn : Integer; 

Temp ; IndexRec; 

beg l n 

for I :« 1 to MaxRec-1 do begin 
Min :« I; 

for J :* 1+1 to MaxRec do 

if KList[J].Key < KList[Min].Key 
then Min :» J; 

Temp KList[I] ; 

KLlst[I] :« KLIst[Min]; 

KLlst[Min] :• Temp 
end 

end; { of proc SortIndexList } 


procedure InitStuff(FIleName 


FileStr; var Error : Integer); 


sets everything up for indexing system. This assumes that 
there are no more than IndexMax (-1000) records, and that the 
records are numbered 1..IndexMax. Record #0 is the header 
record and is used to store the current number of records 
actively being used In the file 


var 

Indx,TErr : Integer; 

TRec : DataRec; 

begin 

Error := NoError; 

FOpen(FlIeName,Error); 
if Error <* NoError then begin 
MaxRec := 0; 

FRead(0,TRec,TErr); 

Error :» TErr; 

MaxRec :* TRec.NumRecs; 
for Indx :* 1 to MaxRec do begin 
FRead(Indx,TRec.TErr); 
if TErr > 0 
then Error :« TErr; 

KList[Indxl.Key :■ TRec.Key; 
KList[indx].Num :■ Indx 
end; 

SortlndexList 

end 

end; { of proc InitStuff { 


procedure CleanUpStuff(var Error ; Integer); 

this just does an orderly shutdown and should be called 
before you leave your program (or open another data file) 

var 

TRec : DataRec; 

begin 

TRec.NumRecs :» MaxRec; { save out # of records \ 

FWrite(0,TRec.Error); 

FCIose(Error) 

end; { of proc CleanUpStuff \ 

LISTING 3. Initialization and cleanup routines. 
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function FindKey(Key : Keytype) : Integer; 

looks for Key in KList; returns location in KList 
if found; otherwise returns - 1 

\ 

var 

L,R,Mid : Integer; 

beg i n 

L :« 1; R :« MaxRec; 
repeat 

Mid (L+R) div 2; 
if Key < KList[Mid].Key 
then R :« Mid-1 
else L :* Mid+1 

until (Key * KList[Mid].Key) or (L > R); 

If Key « KList[MidJ.Key 
then FindKey := Mid 
else FindKey :* -1 

end; j of proc FindKey } 

procedure GetRecord(Key ; Keytype; var Rec ; DataRec; 

^ var Error : Integer); 

looks through KList for Key; if found, returns in Rec. 

It and the routines that follow assume the procedure Seek 
for random access of the file of records. 

} 

var 

Item : Integer; 

beg i n 

Error := NoError; 

Item FindKey(Key); 

1f Item > 0 

then FRead(KList[Item].Num,Rec,Error) 
else Error :* RecordNotFound 
end; j of proc GetRecord j 

procedure PutRecord(Rec : DataRec; var Error : Integer); 

writes Rec out to the file. If a record with that 
key already exists, then overwrites that record; 
otherwise, adds the record to the end of the file. 

If there's no more room for records, exits with an 
error code 

\ 

var 

Item : Integer; 

begin 

Error :■ NoError; 

Item :■ F1ndKey(Rec.Key); 

If I tern >■ 0 

then FWrite(KList[I tern].Num,Rec,Error) 
else if MaxRec < IndexMax then begin 
MaxRec :■ MaxRec + 1; 

FWrite(MaxRec,Rec,Error); 

KListTMaxRecl.Key :■ Rec.Key; 

KList[MaxRecJ.Num ;- MaxRec; 

SortlndexList 

end 

else Error ;■ NoMoreRoom 
end; j of proc PutRecord \ 

LISTING 4. Basic record access routines. 


procedure AddRecord(Rec ; DataRec; var Error : Integer); 

adds a record to the file. If a record with the same 
^ key already exists, then exits with an error code 

var 

Item ; Integer; 

begin 

Error NoError; 


( continued) 
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Item :■ FIndKey(Rec.Key); 

If Item > 0 

then Error :■ AlreadyExIsts 
else PutRecord(Rec.Error) 
end; { of proc AddRecord \ 

procedure DeIeteRecord(Key : Keytype; var Error : Integer); 

deletes the record with 'Key* by copying the last record 
In the file to that slot, then modifies KLIst by shuffling 
a I I the key entrles up 

} 

var 

Item,Last.Max,MVal : Integer; 

TRec ; DataRec; 

begin 

Error :* NoError; 

Item ;■ FIndKey(Key); 

If Item - -1 

then Error :■ RecordNotFound 
else begin 

Max 1; MVal :■ KList[Max].Num; 
for Last :■ 2 to MaxRec do 

If KLIst[Last].Num > MVal then beain 
Max :■ Last; MVal :■ KList[Last].Num 
end; 

If Max <> Item then begin 

FRead(MVal,TRec,Error); } get last record In file } 

FWrIte(KList[Item].Num,TRec,Error); { write over it \ 

KLIst[Max].Num :« KList[Item].Num 
end; 

for Last Item to MaxRec -1 do \ delete KLIstfltem] * 

KLIst[Last] :« KLIst[Last+1]; 

MaxRec :» MaxRec - 1 { adjust § of records } 

end 

end; j of proc DeleteRecord } 

LISTING 5. Higher-level record access routines. 


hI Ibert.bas 
TEXT 

Programming Insight: "Hilbert Curves Made Simple," by Michael Ackerman. 
June, page 137. 


1 GOTO 1000 

2 REM ************************* 

3 REM * HILBERT * 

4 REM * * 

5 REM * BY MICHAEL ACKERMAN * 

6 REM * * 

7 REM * 8/27/85 * 

8 REM ************************* 

100 RDER * RDER - 1 

110 TURN - - TURN 

120 TEMP » DY:DY - - TURN * DX:DX - TURN * TEMP 

130 IF RDER > 0 THEN GOSUB 100 

140 X - X + DX:Y « Y + DY: HPLOT TO X,Y 

150 TURN - - TURN 

160 TEMP « DY:DY = - TURN * DX:DX - TURN * TEMP 

170 IF RDER > 0 THEN GOSUB 100 

180 X = X + DX:Y « Y + DY: HPLOT TO X,Y 

190 IF RDER > 0 THEN GOSUB 100 

200 TEMP - DY:DY - - TURN * DX:DX « TURN * TEMP 

210 TURN * - TURN 

220 X = X + DX:Y « Y + DY: HPLOT TO X,Y 

230 IF RDER > 0 THEN GOSUB 100 

240 TEMP « DY:DY - - TURN * DX:DX « TURN * TEMP 

250 TURN * - TURN 

260 RDER = RDER + 1 

270 RETURN 

1000 TEXT : HGR : HCOLOR* 3: INPUT"ORDER <1-7>";RDER 


348 BYTE LISTINGS SUPPLEMENT 







J me 


1010 POKE 49234,1 

1020 DY « 192 / 2 * RDER 

1030 TURN «= - 1 

1040 DX * X - Y - 0 

1050 HPLOT X,Y 

1060 GOSUB 100 

1070 END 


froctol.lib 
TEXT 

"Musical Fractals," Charles Dodge ond Curtis R. Bahn. 

June, page 185. All the programs mentioned in one TEXT file. 


1 REM WHITE.BAS is in MSX BASIC with MUSIC MACRO 

2 REM commands for the Yamaha CX5-M music computer 

10 _INIT:_INST(1) 

20 X-RNO(-TIME) 

30 FOR X - 1 TO 25 

35 REM notes in range of 25 to 120 

40 N - INT(RND(1)*95)+25 

45 REM lengths In range of 1 to 4 

50 L - INT(RND(1)*4)+1 

60 _PHRASE(1,"L-L;","N-N;") 

70 NEXT X 

80 JPLAY(I.I) 

90 _WAIT(1) 

100 INPUT"AGAIN";DD:GOTO 80 


1 REM BROWN.BAS is in MSX BASIC with MUSIC MACRO 

2 REM commands for the Yamaha CX5-M music computer 

10 _INIT: _INST (1) 

20 X-RND(-TIME) 

30 N-60:L-2 

40 FOR X - 1 TO 25 

45 REM R varies the range of the distribution 

50 R-3:GOSUB 130:N=N+D 

60 IF N>120 or N<25 THEN N«N-2*D 

70 R-.667:GOSUB 130:L-L+D 

80 IF L<1 OR L>4 THEN L-L-2*D 

90 _PHRASE(1."L-L;".N»N;") 

100 NEXT X 

110 _PLAY(1,1):_WAIT(1) 

120 INPUT"AGAIN";DD:GOTO 110 

130 REM BROWNIAN ROUTINE 

140 S-0:REM S is Sum 

150 FOR I - 1 TO 12 

160 S-S+RND(1) 

170 NEXT I 

180 D-INT(R*(S-6)) 

190 RETURN 


1 REM 10VERF.BAS is in MSX BASIC with MUSIC MACRO 

2 REM commands for the Yamaha CX5-M music computer 

10 _I NIT: _I NST (1): IL-8: LN-16: S-60: X=RND ( -TIME ) 

20 FOR X - 1 TO 25 

30 D-N:GOSUB 130 

40 N-D:SN-N+S 

50 D-L:GOSUB 130 

60 l-D:SL-LL+1 

70 _PHRASE(1,"L«SL;","N*SN;“) 

80 NEXT X 

90 _PLAY(1,1) 

100 _WAIT(1) 

110 INPUT"AGAIN";DD 

120 GOTO 90 

130 REM 1/F ROUTINE 

135 REM L Is last value. K Is 1/2 poss values. PR0BIT-1/K 

140 L-D:D-0:K-16:PROBIT-.03125 

150 J-INT(L/K) 


(continued) 
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160 IF J-1 THEN L-l-K 
170 U-RND(I) 

180 IF U < PROBIT THEN J-1-J 

190 D-D+J*K 

200 K-K/2 

210 PR0BIT-PR08IT*2 

220 IF K>1 THEN GOTO 150 

230 RETURN 


1 REM VARIATN.BAS is in MSX BASIC with MUSIC MACRO 

2 REM commands for the Yamaho CX5-M music computer 

4 REM 

5 REM************************************************************* 

6 REM Copyright 198$ Curtis Bohn, Creative Associates Inc. 

7 REM************************************************************* 

8 REM 

10 CLS 

20 DIM P(6):DIM AP(6):DIM BP(36):DIM CP(216) 

30 DIM D(6):DIM AD(6):DIM BD(36):DIM CD(216) 

40 DT-0:CC-0:BC-0:AC-0:GP=0: R-0:HP-100 

50 _INIT:_INST(1):_INST(2):_INST(3) 

100 INPUT"HOW MANY NOTES IN SET?"; PN:IF PN>6 OR PN<1 THEN GOTO 100 

110 PRINT"INPUT";PN;"PITCH RELATIONSHIPS" 

120 FOR LOOP-1 TO PN 

130 INPUT P(LOOP):IF ABS(P(LOOP))>12 THEN PRINT"TOO BIG":GOTO 130 

135 IF GP<P(LOOP)THEN GP-P(LOOP):IF BP>P(LOOP)THEN BP-P(LOOP) 

140 NEXT LOOP 

150 PRINT "INPUT";PN;"TIME RELATIONSHIPS" 

160 FOR LOOP-1 TO PN 

170 INPUT D(LOOP) 

180 NEXT 

185 INPUT"BROWNIAN RANDOMIZER APPLIED TO PITCH (1 OR 0)";R:IF R>2 GOTO 185 

190 PP-ABS(BP)+ABS(GP) 

195 LP-HP-(3*GP):SK»100/(3*PP) 

200 REM FRACTAL ROUTINE 

205 PRINT"COMPUTING FRACTAL" 

210 FOR A-1 TO PN 

220 AP(A)-P(A)+RC:AD(A)-D(A) 

230 FOR B-1 TO PN 

240 BC-BC+1:IF R -1 THEN GOSUB 700 

245 BP(BC)-AP(A)+P(8)+RC:BD(BC)-D(B)*D(A) 

250 FOR C-1 TO PN 

260 CC-CC+1;IF R-1 THEN GOSUB 700 

270 CP(CC)=BP(BC)+P(C)+RC:CD(CC)=D(C)*BD(BC):DT»DT+CD(CC) 

280 NEXT C: NEXT B: NEXT A 

290 TS-255/DT 

300 REM PLAYING ROUTINE 

310 BC-0:CC-0 

320 FOR A-1 TO PN 

330 _SOUND(1.1.AP(A)+LP):CIRCLE(TC.90-(AP(A)*SK)).6 

340 FOR B= 1 TO PN 

345 BC=BC+1 

350 _S0UND(2,1,BP(BC)+LP):CIRCLE(TC,90-(BP(BC)*SK)),3 

360 FOR C- 1 TO PN 

370 _SOUND(3,1.CP(CC)+LP):CIRCLE(TC.90-(CP(CC)*SK)).1 

380 FOR LOOP-1 TO CD(CC):TC-TC+TS 

385 REM all ploy statements here for mono playback 

390 _SOUND(3,0,CP(CC)+LP) 

400 NEXT LOOP 

410 NEXT C: NEXT B: NEXT A 

420 _STOP(1): _STOP(2): _ST0P(3) 

430 INKEY$=DD$: IF DD$="" THEN GOTO 430 

440 GOTO 300 

500 REM BROWNIAN ROUTINE 

510 S=0 

520 FOR I- 1 TO 12 

530 S«S+RND(1) 

540 NEXT I 

550 RC»INT(2*(S-6)) 

560 RETURN 


1 REM RANDOM.BAS is in MSX BASIC with MUSIC MACRO 

2 REM commands for the Yamaha CX5-M music computer 

4 REM 
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REM******************************************************* 

REM Copyright 1986 Charles Dodge, North Cape Music 
REM******************************************************* 

REM 

CLS 

DIM AP(10):DIM BP(100):DIM CP(255):DIM DP(2,255):TC«20 
DIM BD(10):DIM CD(100):DIM DD(255) 

DT-0:DC=0:CC=0:BC=0:AC=0:DIM CT(4) 

DIM CF(4,12):DIM LAST(4):KN=50 
X-RND(-TIME):LAST(1)«INT(RND(1)*32) 

_INIT:_INST(1):_INST(2):_INST(3):_INST(4) 

_MODI(1,5)MODI(2,40):_MODI(3,15):_MODI(4,16) 

FOR LOOP = 1 TO 4 

PRINT"ENTER PITCH CLASS LIMIT OF LEVEL #**;LOOP 
INPUT PL(LOOP) 

IF PL(L00P)>6 THEN PRINT"TOO BIG":GOTO 120 
IF PL(L00P)<1 THEN PRINT"TOO SMALL*' :GOTO 120 
NEXT LOOP 
L-1 

FOR A * 1 TO 10 
GOSUB 820 

IF CT(L)>PL(L) THEN GOTO 230 

AC-AC+1 

AP(A)*LAST(L) 

NEXT 

REM FRACTAL ROUTINE 

SCREEN 2 

FOR A = 1 TO AC 

CIRCLE(DI/2.197-(AP(A)*5+20)),9 
LAST(2)-AP(A) 

FOR B = 1 TO 10 
L-2 

GOSUB 820 

IF CT(L)>PL(L) THEN GOTO 570 
BI«BI+1:BP(BI)*LAST(L) 

CIRCLE(DI/2,197-(BP(BI)*5+20)),6 
LAST(3)*BP(BI) 

FOR C * 1 TO 10 
L-3 

GOSUB 820 

IF CT(L)>PL(L) THEN GOTO 550 

CI-CI+1:CP(CI)-LAST(L):IF CI-255 THEN AC«A:GOTO 590 

CIRCLE(DI/2,197-(CP(CI)*5+20)),3 

LAST(4)-CP(CI) 

FOR D - 1 TO 10 
L-4 

GOSUB 820 

IF CT(L)>PL(L) THEN GOTO 530 
DI-DI+1 

CIRCLE(DI/2,197-(LAST(L)*5+20)),.5 
IF DI>255 THEN GOTO 500 
DP(1,DI)*LAST(L):GOTO 520 
DP(2,DI-255)«LAST(L) 

IF DI*510 THEN AC - A: GOTO 590 
DC*DC+1:NEXT D 

DD(CI)«DC:DC«0:CT(L)*0:GOSUB 1020 
CC-CC+1:NEXT C 

CD(BI)-CC:CC-0:CT(L)-0:GOSUB 1020 

i • kiry t p 

BD(A)*»BC:BC=0:CT(L)=0: GOSUB 1020 
NEXT A 

LINE (0,0)-(255,0):LINE (255,0)-(255,197): 

LINE(255,197)-(0,197):LINE(0,197)-(0,0) 

DD$»INKEY$:IF DD$»"" GOTO 600 
REM PLAY LOOPS 
FOR A - 1 TO AC 
_SOUND(1,1,AP(A)+KN) 

FOR B - 1 TO B0(A):BC-BC+1 
_S0UND(2,1,BD(BC)+KN) 

FOR C - 1 TO CD(B):CC*CC+1 
IF CC>255 GOTO 770 
_S0UND(3,1,(CP(CC)+KN) 

FOR D - 1 TO DD(C):DC-DC+1 

IF DC>255 GOTO 740 

_S0UND(4,1,DP(1,DC)+KN):GOTO 760 

.SOUND(4,1,DP(2,DC-255)+KN) 

(i continued ) 
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750 IF DC-510 THEN GOTO 770 

760 NEXT D:NEXT C:NEXT 8:NEXT A 

770 _STOP(1):_ST0P(2):_ST0P(3):_ST0P(4) 

780 DD$-INKEY$:IF DD$-"" GOTO 780 

790 BC-0:CC-0:DC-0 

800 GOTO 610 

820 REM 1/F ROUTINE 

830 LL-LAST(L):NP-0:K-16:PROBIT-.03125 

840 J-INT(LL/K) 

850 IF J-1 THEN LL-LL-K 

860 U-RND(I) 

870 IF U<PROBIT THEN J-1-J 

880 NP«NP+J* *K 

890 K-K/2 

900 PROBIT - PROBIT*2 

910 IF K>-1 GOTO 840 

920 LAST(L)»NP:TEST-NP 

930 REM PITCH CLASS TEST 

940 FOR I - 0 TO 11 

950 IF INT((TEST+I)/12)-(TEST+I)/12 

THEN CF(L,I)-1:GOTO 920 
960 NEXT I 

970 CT(L)-0 

980 FOR I - 0 TO 11 

990 CT(L)»CF(L,I)+CT(L) 

1000 NEXT I 

1010 RETURN 


midi.arc 
BINARY 

"MIDI Programming" by Donald Swearingen. 

June, page 211. All the programs from the article. Requires ARC. 


LIST1.PAS 


const 

TIMING.OVERFLOW * 248; { MPU-401 Constants \ 

NOP = 248; 

MEASURE.END = 249; 

DATA_END = 252; 

MAX_TIMING — COUNT = 240; 


TIMEBASE = 120.0; 
TEMPO = 100.0; 


\ MPU-401 Default Timebase \ 
| MPU-401 Default Tempo j 


MIN_MIDI_DATA = 0; 
MAX_MIDI.DATA =127; 


{ Minimum MIDI Data Value f 
| Maximum MIDI Data Value \ 


NOTE_OFF =0; { MIDI Commands } 

NOTE_ON = 1; 

AFTER_TOUCH_K = 2; 

CONTROL_CHANGE = 3; 

PROGRAM_CHANGE = 4; 

AFTER_TOUCH_P = 5; 

PITCH_WHEEL = 6; 

SYSTEM.EXCLUSIVE = 7; 


MIDI_MESS_TEXT : { MIDI Command Text Strings } 

array[0..7] of string[20] = 

('Note Off*, 

’Note On *, 

’After Touch (key)’, 

*Cont roI Change *, 

’Program Change’, 

’After Touch (poly)', 

’Pitch Wheel’, 

'System ExcI usive’); 


ERR - -1; { Function error flags \ 

NOERR =0; 5 


352 BYTE LISTINGS SUPPLEMENT 








June 


TRACK_DATAF11E_SIZE = 4096; { MPU-401 track data file \ 

FILENAMEJ.EN = 14; \ MSDOS filename length \ 

RECORD_LEN = 128; \ MSDOS record length } 

DIGITS : j Hex conversion digits } 

array[0..15] of char = 

'0123456789ABCDEF'; 


LIST2.pas 


type 

hex_str = string[2]; 
track_event_type = 

( 

OVFL, 

MARK, 

MIDI, 

MIDI.RS, 

UNKNOWN 

); 


Result of byte—>hex conversion 
{ MPU-401 Track event type 

{ Timing Overflow 
I MPU mark 

MIDI using curr. running status 
MIDI setting new running status 
{ Undefined track event 


track_event = { Single track event 

record 

time : byte; { Event relative time 

mess : array[1..3] of byte; \ Event directive 

end; 

track_event_bIock = { Track event access environment 

record 

running_status : byte;} Current track running status 
event_len : 1..4;{Event Iength,incIuding timing byte 
event_type ; track_event_type; 
event : track_event; 
end; 

track_data_stream = { In memory track data stream file 

array[1..TRACKJDATAFILE.SIZE] of byte; 
track_data_bIock ={ track data stream access environment 
record 

tds : track_data_stream; { track data 

{ track data read pointer 
tds_ptr : 1..TRACK_DATAFILE_SIZE; 

edat ; boolean; { indicates end of track data 

curr : track_event_block; { current track event 

end; 


const 


{ Track overflow event constant 
OVFl_EVENT : track_event_bIock = 

( { used to insert timing spacers 

running_status:0; { into Track Data Stream 

event_len:1; 
event_type:OVFL; 
event: 

( 

time:MAX_TIMING_COUNT; 
mess:(0,0,0) 



\ 


} 

I 


\ 

{ 

\ 

\ 

i 

\ 


\ 

I 

I 


LIST3.PAS 


{ Return true if input is a MIDI status byte 

function midi_status(midi_doto_byte:byte):boo I eon; 
begin 

if (midi_doto_byte > MAX_MIDI_DATA) then 
midi_stotus:*true 
e I se 
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midi.status:«false; 

end; 

| Return the channel # from a MIDI status byte 

function midi_chan(running_status:byte):byte; 
begin 

mldI.chan:«runnIng.status and 15; 
end; 

| Return the command portion of a MIDI status byte 

function midi.cmnd(running.status:byte):byte; 
begin 

midi.cmnd:*(running.status shr 4) and 7; 
end; 

{ Return # of data bytes associated 
^ with a given MIDI status byte 

function nmdat(running.status:byte):byte; 
beg i n 

if (midi.cmnd(running.status) In 

[PROGRAM.CHANGE, AFTER.TOUCH.P]) then 
nmdat:*1 
e I se 

nmdat:«2; 
end; 

| Limit input to valid MIDI data range 

function mldi.data.limit(midi.data.byte:integer):byte; 
beg i n 

if midi.data.byte < MIN.MIDI.DATA then 
midi.data.limit:-MIN.MIDI.DATA 
else If midi.data.byte > MAX_MIDI DATA then 
midi.data.limit:-MAX.MIDI.DATA 
e I se 

midi.data.Iimit:=mIdi.data.byte; 
end; 


LIST4.PAS 


| Reset status and pointer variables In track data block 

procedure reset.track.data(var tdt:track.data block); 
beg i n 

with tdt do 
beg i n 

tds.ptr:*1; 
edat:«fa Ise; 
cur r . runn i ng.status :*=0; 
cu r r.event.type:-UNKNOWN; 
end; 
end; 

j Load track data stream from user 
^ specified file into track data block 

procedure Ioad.track.data(var tdt;track.data.bIock); 
var 

tdf : File; 

tdfn : string[FILENAME.LEN]; 
begin 

reset.track_data(tdt); 
write(*Track data filename: *); 
readIn(tdfn); 
assign(tdf,tdfn); 
reset(tdf); 

bIockread(tdf,tdt.tds.TRACK.DATAFILE.SIZE div RECORD LEN); 
c lose(tdf); 
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end; 

{ Save track data stream from track 
data block to user specified file 

procedure save_track_data(tdt:track_data_bIock); 
var 

tdf : File; 

tdfn : string[FILENAME_LEN]; 
beg i n 

write(’Track data filename: '); 
readIn(tdfn); 
assign(tdf,tdfn); 
rewrite(tdf); 

bIockwrite(tdf,tdt.tds,TRACK_DATAFILE_SIZE div RECORD_LEN); 

c lose(tdf); 

end; 

\ Return current track data byte from track data block 

\ 

function this_byte(tdt:track_data_bIock):byte; 
begin 

this_byte:*tdt. tds[tdt.tds_ptr]; 
end; 

{ Advance pointer to next track data byte 
in track data block 

\ 

procedure advance(var tdt:track__data_bIock); 
beg i n 

tdt. tds_pt r :=tdt. tds_.pt r+1; 
end; 

{ Convert byte to hexadecimal ASCII string 

function itox(i:byte): hex_str; 
beg i n 


i tox 

■0' 

:=chr(2); 



itox 

Y 

:=DIGITS[i 

div 

16 ] 

itox 

2' 

:“DIGITS[i 

mod 

16] 


end; 

{ Dump track data stream in hexadecimal format 

procedure dump_track_data(var tdt: track__data_b lock) ; 
label 
return; 
var 

n,st,off : integer; 
begin 

wr i teIn('Track Data Stream Dump...'); 
wr I teIn; 
write(' '); 

for n:=0 to 15 do 
wr i te(itox(n):4); 
wr i teIn; 
n :-0; 

while (n < TRACK_DATAFILE__SIZE div 16) do 
beg i n 
st:*n*16; 

wr ite(itox(st div 256):2,itox(st mod 256):2,' '); 
for off:«0 to 15 do 
beg i n 

wr i te(itox(ord(tdt.tds[st+off+ 1])):4); 
if (tdt.tds[st+off+1] - DATA_END) then 
goto return; 
end; 

wr I teIn; 
n :«n+1; 
end; 
return: 
wr iteIn; 
end; 
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LIST5.PAS 


{Fill in the message bytes of the current 
Track Event in a Track Data Block 

I 

procedure track.event.message(var tdt:track.data.block); 
var 

I : byte; { index counter } 
label 
return; 
beg i n 

with tdt.curr do 
beg I n 

case this.byte(tdt) of 

NOP, MEASURE.END, DATA.END: 
begin 

event_type:-MARK; 

If (thls_byte(tdt) - DATA_END) then 
tdt.edat:-true; 

event.mess[event.Ien]:«this_byte(tdt); 

event.l en :-event.l en+1; 

advance(tdt); 

goto return; 

end; 

128..239: { MIDI status byte \ 
beg I n 

runningstatus:-this_byte(tdt); 
event_type:-MIDI_RS; 
event.mess[event.Ien]:-this_byte(tdt); 
event.len:-event.Ien+1; 
advance(tdt); 
end; 
e I se 

event_type:-MIDI; 
end; { case } 

{ fill in MIDI data bytes } 

for i:«1 to nmdat(tdt.curr.running.status) do 
beg i n 

event.mess[event.Ien]:-this_byte(tdt); 
event.I en:-event.Ien+1; 
advance(tdt); 
end; 

end; { with tdt.curr } 
return: 
end; 

{ Advance to the next Track Event in a Track Data Block 

} 

procedure next.track.event(var tdt:track.data.bIock); 
label 
return; 
beg i n 

If (tdt.edat) then { end of data { 
goto return; 
with tdt.curr do 
beg i n 

event.len:*1; { count event time } 
case this.byte(tdt) of 
TIMING.OVERFLOW: 
beg i n 

event.type:=OVFL; 

e v e n t.tim e:-MAX.TIMING.COUNT; 

advance(tdt); 

goto return; 

end; 

0..239: { timing byte } 
begin 

event.time:»this.byte(tdt); 
advance(tdt); 
track.event.message(tdt); 
end; 

end; { case ( 
end; { with tdt.curr } 
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return: 

end; 


I me 


{ Store a Track Event In a designated Track Data Block 
\ 

procedure store.track.event(var tdo:track.data.bIock; 

ebIk:track.event.block); 


var 

I : byte; { index counter } 
beg i n 

case eblk.event.time of 
MAX.TIMING.COUNT: 
beg i n 

tdo.tds[tdo.tds.pt r]:«TIMING.OVERFLOW; 

advancedtdo); 

end; 

0..239: 

beg I n 

tdo.tds[tdo.tds.ptr]:*ebIk.event.time; 
advance(tdo); 

for I:*1 to ebIk.event.len - 1 do 
beg I n 

tdo.tds[tdo.tds.ptr]:=ebIk.event.mess[i]; 
advance(tdo); 
end; 
end; 

end; { case \ 
end; 


{ Display a track event on the user console 

procedure dIsp.event(ebIk:track.event.block); 
var 

I : byte; { index counter } 
label return; 
beg i n 

with eblk do 
begin 

wr i te(event.time:4); 
if (event.len * 1) then 
beg i n 

write(' Timing Overflow*:16); 

goto return; 

end; 

if (event.mess[1] in [NOP,MEASURE.END,DATA.END]) then 
beg I n 

case event.mess[1] of 
NOP : 
beg i n 

wr i te(’NOP*:16); 
goto return; 
end; 

MEASURE.END: 
beg i n 

write(’Measure End':16); 

goto return; 

end; 

DATA.END: 
beg i n 

wr i te(’Data End’:16); 

goto return; 

end; 

end; {case} 
end; |if{ 
i :-1; 

If (midl.status(event.mess[1])) then 
beg I n 

write(MIDI.MESS.TEXT[midi.cmnd(event.mess[1])]:16); 

I:*I+1; 

end 

e I se 

wr 1te(* *:16); 

while (i <■ (event.len - 1)) do 
begin 

wr1te(event.mess[i]:4); 
i:-l+1; 
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end; 

end; j with eblk } 
return: 
wrIteIn; 
end; 

| Display all of the Track Events In a Track Data Block 

procedure dIsp_track_data(var tdt:track_data_bIock); 
var 

time ; real; { Actual time of current track event j 
beg i n 

time:=0.0; 

reset_track_data(tdt); 
while not(tdt.edat) do 
begin 

next_track_event(tdt); 
tlme:*tIme+tdt.curr.event.time; 
wr Ite( ((time*60)/(TIMEBASE*TEMPO)):8:3 ); 
disp_event(tdt.curr); 
end; 
end; 


LIST6.PAS 


j Return offset of MIDI key data In 
Track Event message, If present 

function midi_key_offset(var ebIk:track_event_bIock; 

chan rbyte):integer; 

begin 

midijkey_offset:»ERR; { default return value \ 
with eblk do 
begin 

if ((event_type In [MIDI, MIDI_RS]) 
and (midi_cmnd(running_status) 

In [NOTE.OFF, NOTE_ON, AFTER_TOUCHJ<]) 
and (midi_chan(running_status) * chan)) then 
begin 

midi_k ey_of f s e t:*1; 
if (event_type = MIDI_RS) then 
midi_key_of fset:*2; 
end; 

end; { with eblk \ 
end; 

} Return MIDI key data from Track Event, if present 

function get_midi_key(var ebIk:track_event_bIock; 

chambyte): integer; 

var 

key_offset : integer; 
begin 

get_midij<ey:=ERR; { default return value } 
key_offset:=midI_key_offset(ebIk,chan); 
if (key_offset <> ERR) then 
get_midi_key:«ebIk.event.mess[key_offset]; 
end; 

{ Set MIDI key value in a Track Event, 
if Track Event is of appropriate type 

procedure set_midi_key(var eblk:track_event_bIock; 

chan.keyrbyte); 

var 

key_offset : integer; 
begin 

key_offset:*midi_key_offset(ebIk,chan); 
if (key_offset <> ERR) then 
eblk.event.mess[key_of fset]:=key; 
end; 
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j Transpose all MIDI pitch (key) data 
for a channel in a Track Data block 

i 

procedure transpose_pitch(var tdi,tdo:track_data_block; 

chan,trans:integer); 

var 

curr_key : integer; j MIDI key value from 

current track event } 

beg i n 

reset_track_data(tdi); 
reset_track_data(tdo); 
while not(tdi.edat) do 
beg i n 

next_track_event(tdi); 

curr_key:=get_midi_key(tdi.curr,chan); 

If (curr_key <> ERR) then 
set_midi_key(tdi.curr,chan, 

midi_data_limit(curr_key+trans)); 
store_track_event(tdo,tdi.curr); 
end; 
end; 


LIST7.PAS 


{ Return offset of MIDI velocity data in 
Track Event message, if present 

function midi_vel_offset(ebIk:track_event_bIock; 

chan:byte):integer; 
var 

offset : integer; 
beg i n 

midi_vel_offset:«ERR; { default return value \ 

j only MIDI key events have velocity \ 
offset:«midi_key_offset(ebIk,chan); 
if (offset <> ERR) then 

midi_vel_offset:«offset+1; 
end; 

{ Return MIDI velocity data from Track Event, if present 

function get_midl_vel(eblk:track_event_block; 

chan:byte):Integer; 

var 

vel_offset : integer; 
begin 

get_mi di_ve I :*ERR; \ def-ault return value } 
vel_offset:*midi_vel_offset(ebIk,chan); 
if (vel_offset <> ERR) then 
get_midi_veI:=ebIk.event.mess[vel_offset]; 
end; 

{ Set MIDI velocity value in Track Event, 
if Track Event is of appropriate type 

procedure set_midi_veI(var ebIk;track_event_block; 

chan,veI;integer); 

var 

vel_offset : integer; 
beg i n 

vel_offset;«midl_vel_offset(ebIk,chan); 
if (vel_offset <> ERR) then 
ebIk.event.messfvel_of fset]:*veI; 
end; 

{ Scale all MIDI velocity data for 
a channel in a Track Data block 

i 

procedure sea Ie_veI(var tdI,tdo:track_data_bIock; 

chan:Integer; vel_fact:reaI); 

var 

curr_vel : Integer; 

(continued) 
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begin 

reset_track_data(tdi ); 
reset_track_data(tdo); 
while not(tdI.edat) do 
begin 

next_track_event(tdi); 

curr_vel:»get_midi_veI(tdi.curr,chan); 

If (curr_vel <> ERR) then 

set_midi_veI(tdi.curr, chan,trune(curr_veI*vel_fact)); 
store_track_event(tdo,tdi.curr); 
end; 
end; 


LIST8.PAS 


j Redirect MIDI channel data In a 
Track Data Block to a new channel 

\ 

procedure change_chan(var tdi,tdo:track_data_bIock; 

oId_chan,new_chan;byte); 

begin 

reset_track.dataftdi}; 
reset_track_data(tdo); 
while not(tdi.edat) do 
beg i n 

next_track_event(tdi); 
wl th tdi.curr do 
begin 

if (event_type * MIDI_RS) and 

(midi_chan(running_status) *= old_chan) then 
event.mess[1]:«((event.mess[1] and $F0) or new.chan); 
store_track_event(tdo,tdI.curr); 
end; 
end; 
end; 


j Extract a single MIDI channel from a Track Data Block 

procedure extract_chan(var tdi,tdo:track_data_block; 

chan:byte); 


begin 

reset_track_dataftdi); 
reset_track_data(tdo); 
while not(tdi.edat) do 
beg i n 

next_track_event(tdl); 
with tdi.curr do 
beg i n 

If (event_type in [MIDI_RS,MIDI]) 
and (midi_chan(running_status) <> chan) then 
begin j convert to NOP j 
event_type:«MARK; 
event_len:*2; 
event.mess[l]:*NOP; 
end; 
end; 

store_track_event(tdo,tdi.curr); 
end; 
end; 


| Filter a MIDI channel from a Track Data Block 

procedure fiIter_chan(var tdi,tdo:track_data_block; chan:byte); 
begin 

reset_track_data(tdi); 
reset_track_data(tdo); 
while not(tdi.edat) do 
beg i n 

next_track_event(tdi); 
wi th tdi.curr do 
begin 

If (event_type in [MIDI_RS, MIDI]) 
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and (midi_chan(running_status) = chan) then 
begin { convert to NOP } 
event_type:=MARK; 
event_len:=2; 
event.mess[1]:=NOP; 
end; 

end; 

store_track_event(tdo,tdi.curr); 
end; 
end; 


LIST9.PAS 


procedure quantize(var tdi,tdo:track_data_b lock ; 

quantum:integer); 


var 

in_time 


rea I 


out_time : reaI ; 


et ime 


integer; 
integer; 


i 


Actual elapsed time, 
input track data block 
Actual elapsed time, 
output track data block 
Temporary storage for 
adjustment of event time 
Rounding term 




qround 
begin 

reset_track_dataftdi); 
reset_track_data(tdo); 
qround:=quantum div 2; 
in_time:«0.0; 
out_time:=0.0; 
while not(tdi.edat) do 
beg i n 

next_track_event(tdi ) ; 
with tdi.curr do 
beg i n 

etime:=event.time; 
j Adjust in/out time variance } 
etime:-etime - trunc(out_time-ln_tIme); 
j quantize \ 

etime:-trunc(quantum * ((etime + qround) div quantum)) 
in_t1 me:*in_time+event.time; 
out_time:«out_time+etime; 
event.time:»etime; 

while event.time > MAX_TIMING_COUNT do 
beg i n 

s to r e_tr ack_even t(tdo,OVFL_EVENT); 
event.time:»event.time-MAX_TIMING_COUNT; 
end; 

store_track_event(tdo,tdi.curr); 
end; 
end; 
end; 
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var 

tdt1,tdt2 : track_data_bIock; 

begin j main } 
load_track_data(tdt1); 
disp_track_data(tdt1); 
read In; 

wr IteIn(’Transposing pitch for channel 0’); 
transpose_pItchftdt1,tdt2,0,6); 
dump_track.dataftdt2); 
save_track_data(tdt2); 
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wrlteln(’extractlng channel 0'); 
extract_chan(tdt1,tdt2,0); 
disp_track_data(tdt2); 
save_track_dato(tdt2); 

wr i teIn(*fiI terIng channel 0’); 
fiIter_chan(tdt1,tdt2,0); 
disp_track_data(tdt2); 
save_track_dota(tdt2); 

end. { main } 


Iist1.txt 

TEXT 

"Sorting ProDOS Directories," by Antonio C. Silvestri. 
June, page 117. Also download Iist2.txt. 


10 REM PRODOS CATALOG SORT ROUTINE 

20 REM ANTONIO C. SILVESTRI 

30 REM SYSTEMS CONSULTANTS INC. 

40 CLEAR: TEXT: HOME: DB - PEEK(115) + 256*PEEK(116) 

50 FOR 1=768 TO 792: READ H: POKE I,H: NEXT 

60 DIM DIM NA$(55), ST(30), ST$(30), DL(10): N = 0: V = 2: 

V$ = GOSUB 460 

70 VTAB 2: HTAB 6: PRINT "PRODOS FILENAME SORT UTILITY": 

VTAB 9: HTAB 10: PRINT "INSERT DISK IN 
FLASH: PRINT "DRIVE 1";: NORMAL: PRINT: 

HTAB 9: PRINT "HIT ANY KEY TO CONTINUE" 

80 POKE - 16368,0: WAIT - 16384,128: POKE - 16368,0 

90 HOME: PRINT "SEARCHING FOR VALID FILENAMES": PRINT 

100 IF N <= 0 THEN 450 

110 GOSUB 480: BL = V: HE = V: HE$ = V$: CO = 0: BC = 0 
120 POKE 791,BL - 256*INT(BL/256): POKE 792,INT(BL/256): 

POKE 776,128: CALL 768: IF PEEK(786) <> 0 THEN 
PRINT "ERROR IN READING BLOCK NO. ";BL: STOP 
130 BC = BC + 1: DL(BC) = BL 
140 FOR J=0 TO 12: IF J <> 0 THEN 180 
150 IF BL-HE THEN DR$ = "": 

FOR 1=0 TO 38: DR$ = DR$ + CHR$(PEEK(DB + 4 + I)): NEXT: 

HE$ = HE$+"/"+MID$(DR$,2,PEEK(DB+4)-16*INT(PEEK(DB+4)/16)): 
PRINT "READING DIRECTORY: ";HE$ 

160 PRINT "BLOCK NO. ";BL;" READ" 

170 IF BL = HE THEN 210 

180 IF PEEK (DB + 4 + J * 39) = 0 THEN PRINT "D";: GOTO 210 
190 PRINT CO = CO + 1: NA$(CO) = "": 

FOR 1=0 TO 38: NA$(C0)=NA$(C0)+CHR$(PEEK(DB+4+J*39+I)): NEXT 
200 IF ASC(MID$(NA$(CO),17,1))=15 THEN 

V = ASC(MID$(NA$(CO),18,1)) + 256*ASC(MID$(NA$(CO).19.1)): 
V$ = HE$: G0SU8 460 

210 NEXT J: PRINT: PRINT: X = FRE (0): 

BL = PEEK(DB+2) + 256*PEEK(DB+3): IF BL <> 0 THEN 120 

220 IF CO=0 THEN HOME: VTAB 10: FLASH: 

PRINT "**WARNING**"; CHR$ (7);: NORMAL: 

PRINT "NO FILENAMES CAN BE FOUND": GOTO 290 
230 IF CO=1 THEN 290 

240 HOME: VTAB 10: PRINT CO:" FILENAMES FOUND";: HTAB 29: 

PRINT "NOW ";: FLASH: PRINT "SORTING": NORMAL: NX = CO 
250 VTAB 17: HTAB 8: PRINT "FILENAMES HAVE BEEN PLACED" 

260 VTA8 17: HTAB 7 - LEN(STR$(CO - NX)): PRINT CO - NX 
270 FLAG = 0: FOR I = 2 TO NX: 

IF MID$(NA$(I),2,15) < MID$(NA$(I-1).2.15) THEN 
H$ = NA$(I): NA$(I) = NA$(I-1): NA$(I - 1) = H$: 

FLAG = 1 

280 NEXT: X = FRE(0): NX = NX - 1: 

IF FLAG = 1 AND NX <> 1 THEN 260 
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290 HOME: PRINT "STORING PURGED AND SORTED DIRECTORY": PRINT 

300 A = 1: B = 0: FOR J = 1 TO BC 

310 PRINT "NOW FORMING BLOCK NO. "; DL(J) 

320 IF J = 1 THEN AX = 0: GOTO 340 
330 AX = DL(J - 1) 

340 IF J * BC THEN BX = 0: GOTO 360 
350 BX = DL(J + 1) 

360 POKE DB.AX-256*INT(AX/256): POKE DB+1, INT(AX/256): 

POKE DB+2,BX-256*INT(8X/256): POKE DB+3, INT(BX/256): 

POKE DB+511,0 
370 IF J = 1 THEN 

FOR K=1 TO 39: POKE DB+3+B*39+K,ASC(MID$(DR$,K,1)): NEXT: 
PRINT ".";:B = B + 1 
380 IF A <- CO THEN 

FOR K-1 TO 39: POKE DB+3+B*39+K,ASC(MID$(NA$(A),K,1)): NEXT 
PRINT GOTO 400 

390 FOR K=1 TO 39: POKE DB+3+B*39+K,0: NEXT: PRINT "2"; 

400 A - A+1: B - B+1: IF B < 13 THEN 380 

410 PRINT: PRINT: B = 0: POKE 791,DL(J)-256*INT(DL(J)/256): 

POKE 792, INT(DL(J)/256): POKE 776,129: CALL 768 
420 IF PEEK(786) <> 0 THEN 

PRINT "ERROR IN WRITING BLOCK NO.”;DL(J): STOP 
430 NEXT J: GOTO 90 

440 DATA 169, 0, 141, 18. 3. 32, 0, 191, 0, 19, 3. 176, 1, 

96, 238, 18, 3, 96 . 0, 3, 96, 0. 150, 0, 0 

450 END 

460 IF N >= 30 THEN 

PRINT "STACK OVERFLOW": STOP 
470 N = N+1: ST(N)-V: ST$(N)-V$: RETURN 
480 IF N <- 0 THEN 

PRINT "STACK UNDERFLOW": STOP 
490 V - ST(N): V$ - ST$(N): N - N-1: RETURN 


The PRODOS Diskette Sorting Utility 
Listing #1 
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IIst2.txt 
TEXT 

“Sorting ProDOS Directories," by Antonio C. Silvestri. 
June, page 117. Also download Iist1.txt. 


10 DATA •■/SCRATCH". "/SCRATCH/MASS". "/SCRATCH/RHODE". 
"/SCRATCH/VERMONT". "/SCRATCH/MASS/NY". 
"/SCRATCH/MASS/NJ". "/SCRATCH/RHODE/PA", 
"/SCRATCH/VERMONT/MAINE" 

20 DIM A$(40): D$-CHR$ (4): ONERR GOTO 100 

30 READ H$: PRINT D$;"PREFIX ";H$: PRINT D$;"SAVE TESTFILE" 

40 J=0: L»INT(40*RND(1))+1: PRINT: PRINT: 

PRINT L;" FILES TO BE CREATED": PRINT 
50 FOR K-1 TO L: TY$-"“: FOR 1-1 TO INT(10*RND(1))+1: 

TY$-TY$+CHR$(65+26*RND(1)): NEXT: X-FRE (0) 

60 PRINT K;" ";H$+'7"+TY$: PRINT D$;"OPEN "+TY$: 

PRINT D$;"CLOSE "+TY$: IF RND(1) < .30 THEN J-J+1: A$(J)-TY$ 
70 NEXT K 

80 PRINT J;" FILES TO DELETE": IF J-0 THEN 30 
90 FOR 1-1 TO J: PRINT D$;"DELETE "+A$(I): 

PRINT I;" ";H$+"/"+A$(I): NEXT: GOTO 30 

100 END 


A Program to Create a Testing Diskette for 
the ProDOS Sorting Utility 

Listing #2 


indexbpp.pas 
TEXT 

Programming Project: "A Simple File-Indexing System," by Bruce Webster. 
June, page 92. Also download Indexbpp.Ist. 


i$V-| 

program FI I©Index; 


const 

IndexMax = 1000 
RecCountErr *= -2 
NewFiIeCreated * -1 
NoError * 0 
RecordNotFound « 1 
NoMoreRoom * 2 
AlreadyExists * 3 
OutOfRange * 4 


type 

Keytype 
FileStr 
Whatever 


string 

string 

string 


40 

80 

12 


DataRec » record 
case Boolean of 

True : (NumRecs 
False : (Key 

theRest 


end; 


IndexRec ■ record 

Key : Keytype; 

Num : Integer 

end; 


Integer); 
Keytype; 
Whatever); 
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IndexList ■ array[1..IndexMax] of IndexRec; 


var 

KList 

DFile 

MaxRec 


IndexList; 
file of DataRec; 
Integer; 


| compiler-specific file I/O routines \ 

i these procedures are specific to TURBO Pascal. If you 

are using another Pascal compiler, you will need to 
modify them appropriately. Note that TURBO Pascal does 
not support the standard routines GET and PUT, but instead 
uses READ and WRITE. \ 

{$!-} j turn off I/O error checking \ 


procedure FRead(RNum : Integer; var Rec : DataRec; var Error : Integer); 
reads record #RNum into Rec 

\ 

beg i n 

if (RNum < 0) or (RNum > MaxRec) 
then Error := OutOfRange 
else begin 

Seek(DFiIe.RNum); 

Read(DFiIe,Rec); 

Error :« IOResult; 
if Error > 0 

then Error := 100 + Error 

end 

end; j of proc FRead } 


procedure FWrlte(RNum ; Integer; Rec : DataRec; var Error : Integer); 
writes record #RNum into Rec 

begin 

If (RNum < 0) or (RNum > MaxRec) 
then Error :■ OutOfRange 
else begin 

Seek(DFile,RNum); 

Wr1te(DFiIe,Rec); 

Error :■ IOResult; 
if Error > 0 

then Error :■ 100 + Error 

end 

end; j of proc FRead } 


procedure FOpen(FiIeName : FileStr; var Error : Integer); 

tries to open FIleName; if it doesn't exist, creates 
. it with the appropriate header record 


} "no file" error code for TURBO Pascal 


const 

TurboNoFlIe « 1; 

NoIOError - 0; 

var 

IOCode : Integer; 

TRec : DataRec; 

beg i n 

Assign(DFlle,FileName); 

Reset(DFiIe); 

IOCode :* IOResult; 

if IOCode * TurboNoFile then begin \ file doesn't exist } 
FiI IChar(TRec,SizeOf(TRec),0); 

Rewrite(DF1le); 

TRec.NumRecs :» 0; 

Wrlte(DFile.TRec); 

Close(DFile); 

AssIgn(DFiIe,FIlename); 

Reset(DFile); 

IOCode :•* IOResult; 
if IOCode - NoIOError 

then Error :* NewFiIeCreated 


end; 

if IOCode <> NoIOError 


\ 
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then Error :■ 100 + IOCode; 
end; j of proc FOpen \ 

procedure FCIose(vor Error : Integer); 

closes file 

\ 

begin 

Close(DFIIe); 

Error ;■ IOResult; 

If Error > 0 

then Error :« Error + 100 
end; { of proc FCIose \ 

{$1 + } j turn on I/O error checking \ 

{ Initialization and cleanup routines ( 

procedure SortIndexList; 

\ 

sorts the array KList using a selection sort technique 

var 

I.J.Min : Integer; 

Temp : IndexRec; 

begin 

for I :» 1 to MaxRec-1 do begin 
Min := I; 

for J :* 1+1 to MaxRec do 

if Kllst[J].Key < KList[Min].Key 
then Min J; 

Temp :» KList[I]; 

KList[I] KList[Min]; 

KList[Min] Temp 
end 

end; { of proc SortIndexList \ 

procedure InitStuff(FileName : FlleStr; var Error : Integer); 

sets everything up for indexing system. This assumes that 
there are no more than IndexMax (=1000) records, and that the 
records are numbered 1..IndexMax. Record #0 is the header 
record and is used to store the current number of records 
actively being used in the file 

var 

Indx,TErr : Integer; 

TRec : DataRec; 

begin 

Error := NoError; 

FOpen(FiIeName,Error); 
if Error <* NoError then begin 
MaxRec :* 0; 

FRead(0,TRec,TErr); 

Error := TErr; 

MaxRec :* TRec.NumRecs; 
for Indx :» 1 to MaxRec do begin 
FRead(Indx,TRec,TErr); 
if TErr > 0 
then Error ;» TErr; 

KLIst[Indx].Key := TRec.Key; 

KList[Indx].Num := Indx 
end; 

SortlndexList 

end 

end; | of proc InltStuff \ 

procedure CleanUpStuff(var Error : Integer); 

this just does an orderly shutdown and should be called 
before you leave your program (or open another data file) 

var 

TRec : DataRec; 

beg i n 

TRec.NumRecs := MaxRec; { save out # of records } 
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FWrite(0,TRec,Error); 

FCIose(Error) 

end; { of proc CleanUpStuff \ 

function FlndKey(Key : Keytype) : Integer; 

looks for Key in KList; returns location in KList 
if found; otherwise returns - 1 

i 

var 

L.R.Mid : Integer; 

begin 

L :* 1; R :* MaxRec; 
repeat 

Mid := (L+R) div 2; 
if Key < KList[Mid].Key 
then R Mid-1 

else L Mid+1 

until (Key * KList[Mid].Key) or (L > R); 
if Key = KList[Mid].Key 
then FindKey :* Mid 
else FindKey := -1 

end; j of proc FindKey } 

procedure GetRecord(Key : Keytype; var Rec : DataRec; 

var Error ; Integer); 

looks through KList for Key; if found, returns in Rec. 

It and the routines that follow assume the procedure Seek 
for random access of the file of records. 

\ 

var 

Item ; Integer; 

beg i n 

Error :« NoError; 

Item :■ FindKey(Key); 
if Item > 0 

then FRead(KList[Item].Num,Rec,Error) 
else Error :■ RecordNotFound 
end; { of proc GetRecord } 

procedure PutRecord(Rec : DataRec; var Error : Integer); 

writes Rec out to the file. If a record with that 
key already exists, then overwrites that record; 
otherwise, adds the record to the end of the file. 

If there’s no more room for records, exits with an 
error code 

} 

var 

Item : Integer; 

begin 

Error := NoError; 

Item :« FindKey(Rec.Key); 

If I tern >■ 0 

then FWrite(KList[Item].Num,Rec.Error) 
else if MaxRec < IndexMax then begin 
MaxRec := MaxRec + 1; 

FWrite(MaxRec,Rec,Error); 

KList[MaxRecl.Key Rec.Key; 

KList[MaxRecJ.Num :■ MaxRec; 

SortlndexList 

end 

else Error :■ NoMoreRoom 
end; j of proc PutRecord \ 

procedure AddRecord(Rec : DataRec; var Error : Integer); 

adds a record to the file. If a record with the same 
key already exists, then exits with an error code 

var 

Item ; Integer; 

begin 

Error NoError; 


{continued) 
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Item :■ FindKey(Rec.Key); 

If Item > 0 

then Error :* AlreadyExists 
else PutRecord(Rec,Error) 
end; J of proc AddRecord } 

procedure DeIeteRecord(Key : Keytype; var Error : Integer); 

deletes the record with 'Key* by copying the last record 
In the file to that slot, then modifies KList by shuffling 
a I I the key entries up 

var 

I tern,Last,Max,MVaI : Integer; 

TRec : DataRec; 

begin 

Error := NoError; 

Item :» FindKey(Key); 
i f Item * -1 

then Error :« RecordNotFound 
else begin 

Max := 1; MVal :■ KList[Max].Num; 
for Last :* 2 to MaxRec do 

if KList[Last].Num > MVal then begin 
Max :« Last; MVal := KList[LastJ.Num 
end; 

if Max <> Item then begin 

FRead(MVal,TRec,Error); { get last record in file } 

FWrlte(KList[Item].Num,TRec,Error); | write over it j 
KList[Max].Num KList[Item].Num 
end; 

for Last :■ Item to MaxRec-1 do { delete KList[Item] } 

KList[Last] KList[Last+1]; 

MaxRec :» MaxRec - 1 { adjust # of records } 

end 

end; { of proc DeleteRecord } 

\ USERIO.LIB 


Wr i teStr 
Error 
GetChar 
Yes 

GetString 
IOCheck 


\ 

type 

MsgStr 

CharSet 


procedure and functions in this library 

write message out at (Col,Line) 

writes message out at (1,1), waits for character 

prompt user for one of a set of characters 

gets Y/N answer from user 

prompt user for a string 

checks for I/O error; prints message if necessary 


= string[80]; 

« set of Char; 


var 

IOErr 

IOCode 


Boo Iean; 
Integer; 


procedure WriteStr(Co I,Line : Integer; TStr : MsgStr); 

purpose writes message out at spot indicated 

last update 23 Jun 85 

beg i n 

GoToXY(Col,Line); ClrEol; 

Write(TStr) 

end; j of proc WriteStr } 
procedure Error(Msg : MsgStr); 

purpose writes error message out at (1,1); waits for characte 

last update 05 Jul 85 

const 
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Bell * ^G; 

var 

Ch : Char; 

begin 

Write$tr(1,1,Msg+BeIl+* - • 

Read(Kbd.Ch) 
end; { of proc Error } 

procedure GetChor(var Ch : O: MsgStr; OKSet ; CharSet); 

purpose let use* e--e- ccmw-~d 

last update 23 Jun 55 

begin 

WriteStr(1,1.Prompt); 
repeat 

Read(Kbd.Ch); 

Ch :« UpCase(Ch) 
untiI Ch in OKSet; 

WriteLn(Ch) 

end; { of proc GetChar \ 


function Yes(Question : MsgSt' 5:: -r; 

purpose asks _s*' :.*st on 

last update 03 Ju Sc 

var 

Ch : Cher; 

begin 

GetCharfCh,Question+* (Y S) " [*Y N*l); 

Yes (Ch - *Y’) 
end; { of func Yes | 


procedure GetString(var NStr : MsgStr; Prompt 
. OKSet : CborSmt); 


MsgStr; MaxLen : Integer; 


\ 


purpose 
last update 


get string from user 
09 Jul S5 


- "H; 

* A M; 

: CharSet « 

: MsgStr; 

: Integer; 

: Char; 


const 
BS 
CR 

ConSet : CharSet « [BS.CR]; 

var 
TStr 
TLen.X 
Ch 

beain 

I$I-| | turn off I/O checking J 
TStr 

TLen :* 0; 

WriteStr(1,1.Prompt); 

X :* 1 + Length(Prompt); 

OKSet OKSet + ConSet; 
repeat 

GoToXY(X.I); 

repeat 

Read(Kbd.Ch) 
until Ch in OKSet; 
if Ch « BS then begin 
if TLen > 0 then begin 
TLen :■ TLen - 1; 

X :« X - 1; 

GoToXY(X.I); Write(’ '); 
end 
end 

else If (Ch <> CR) ond (TLen < MoxLen) then begin 
Wrlte(Ch); * 

TLen :* TLen + 1; 

TStr[TLen] :* Ch; 

X :« X + 1; 
end 

until Ch - CR; 


[continued) 
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I f TLen > 0 then begin 
TStr[0] :» Chr(TLen); 

NStr :» TStr 
end 

else Write(NStr) 

{$1 + 1 

end; J of proc GetStrlng f 
procedure IOCheck(IOCode ; Integer); 


purpose 
last update 

$ 

var 
TStr 
begin 
IOErr : 

If IOErr 


check 
19 Feb 


for 

86 


10 error; print message If needed 


strIng[4]; 


(IOCode <> 0); 
then case IOCode 


end 
end; { 


$01 : Error(*I0ERR0R> 

$02 : Error(*IOERROR> 

$03 : Error(*I0ERR0R> 

$04 : Error(*I0ERR0R> 

$10 : Error(*I0ERR0R> 

$20 : Error(*I0ERR0R> 

$21 : Error(*I0ERR0R> 

$22 : Error(*I0ERR0R> 

$90 : Error(*I0ERR0R> 

$91 : Error(*I0ERR0R> 

$99 : Error(*I0ERR0R> 

$F0 : Error(*I0ERR0R> 

$F1 : Error(*I0ERR0R> 

$F2 : Error(*I0ERR0R> 

$FF : Error(*I0ERR0R> 
else Str(I0Code:3,TSt 

Error( , I0ERR0R> 


of 

File does not exist *); 

File not open for Input*); 

File not open for output*); 

FI le not open*); 

Error in numeric format*); 

Operation not allowed on logical device’) 
Not allowed in direct mode’); 

Assign to standard files not allowed*); 
Record length mismatch*); 

Seek beyond end of file*); 

Unexpected end of file*); 

Disk write error *); 

Directory is full*); 

File size overflow*); 

File disappeared*) 
r); 

Unknown I/O error: *+TStr) 


of proc IOCheck \ 


const 

CmdPrompt 


declarations and code for test program 


\ 


: MsgStr = 

*TEST> A)dd, D)elete. F)lnd. L)ist, I)ndex, C)lose, Q(u 
*TEST> Enter file name: *; 

*TEST> Another file?*; 


*A\*D\*F\*L\’I\*C\*Q*]; 
*0*..*9*.*-*.’/’.*(’.*)’]; 


Fi1ePrompt 

: 

MsgStr = 

DonePrompt 

: 

MsgStr = 

CmdSet 

: 

CharSet « 

NameSet 

: 

CharSet « 

PhoneSet 

: 

CharSet 1 

ir 

Cmd 

. 

Char; 

ErrVa1 

: 

Integer; 

F i 1eName 

: 

Fi leStr; 

Done 

; 

Boo 1ean; 


procedure FiIeError(ErrVaI : Integer); 
begin 

if ErrVal < 100 then 
RecCountErr 
NewFiIeCreated 
RecordNotFound 
NoMoreRoom 
Al readyExists 
end 

else begin 

IOCheck(ErrVa1-100) 
end 

end; j of proc FileError { 


case ErrVal of 

Error(’Record count mismatch*); 
Error(’Creating new file*); 
Error(’Record not found*); 

Error( 

Error( 


•(*No more room*); 
'('Record already exists’) 
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add a record to the file 
19 Feb 86 


: MsgStr; 

: DataRec; 


procedure DoAdd; 

purpose 
last update 

i 

var 
TStr 
TRec 
begin 

FiIIChar(TRec,SizeOf(TRec), 0 ); 
with TRec do begin 
TStr := 

GetString(TStr,’ADD> Enter name: 
if TStr <> •• then begin 
Key := TStr; TStr :» 

GetString(TStr,*ADD> Enter phone #: \ 12,PhoneSet); 
theRest :* TStr; 

AddRecord(TRec,ErrVaI); 

FIush(DFlie); 

FiIeError(ErrVaI) 
end 
end; 

end; { of proc DoAdd } 


*,40,NameSet); 


procedure DoDelete; 

purpose delete a record from the file 

last update 19 Feb 86 

i 

var 

Key : Keytype; 

beg i n 

GetStrIng(Key,*DELETE> Enter name: *,40,NameSet); 
DeIeteRecord(Key,ErrVaI); 

Fi leError(ErrVal) 
end; j of proc DoDelete J 


procedure DoFind; 

purpose find a record in the file 

last update 19 Feb 86 


var 

Key : Keytype; 

TRec : DataRec; 

beg I n 

GetStrlng(Key, *FIND> Enter name; •,40,NameSet); 
GetRecord(Key,TRec,ErrVaI); 
if ErrVal « NoError then begin 
WriteStr(1,2,’The phone number is '); 

Wr IteIn(TRec.theRest) 
end 

else FI IeError(ErrVaI) 
end; j of proc DoDelete j 


list out contents of the file 
19 Feb 86 


DataRec; 
Integer; 


procedure DoList; 

purpose 
last update 

i 

var 
TRec 
Indx 
beg i n 

ClrScr; Writeln; 

for Indx :- 1 to MaxRec do with KList[Indx] do begin 
WrIteStr(1,Indx+1,Key); WriteC *:(45-Length(Key))); 
GetRecord(Key,TRec,ErrVaI); 
if ErrVal - NoError then with TRec do 
Writeln(theRest) 
else FileError(ErrVal) 
end 

end; j of proc DoList } 


{continued) 
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procedure Showlndex; 

\ 

purpose list out contents of the key list 

last update 19 Feb 86 

i 

var 

Indx : Integer; 

begin 

ClrScr; Writeln; 

for Indx :■ 1 to MaxRec do with KList[Indx] do 
Write In(Key,* *:(45-Length(Key)),Num:5) 
end; \ of proc DoList \ 

begin 

repeat 

Done :« False; 

ClrScr; 

GetStrlng(FiIeName,FlIePrompt,80.NameSet); 
InitStuff(FIleName.ErrVal); 

FIleError(ErrVal); 
repeat 

GetChar(Cmd.CmdPrompt,CmdSet); 
case Cmd of 


’A’ 

: DoAdd; 

’D’ 

: DoDelete; 

*F* 

: DoFind; 

•L’ 

: DoList; 

•r 

: Showlndex; 

’Q’ 

: Done :* True 

end 

unt11 (Cmd 

■ *C') or Done; 


CleanUpStuff(ErrVaI); 

FiIeError(ErrVaI); 

ClrScr; 
if not Done 

then Done :■ not Yes(DonePrompt) 
untiI Done 

end. { of program Testlndex \ 


midilll.c 

TEXT 

"A MIDI Project," by Jay Kubicky. 

June, page 199. Also download rxintll.a. 


/* MIDInterface 1.11 

Copyright (C) 1985, 1986 By: 

Jay Kubicky 
934 N. Orange St. 

Media, PA 19063 
215-565-7761 

This is a VERY recent version of this program. 

It has not been ’tested* extensively, though all testing that 
has been done shows favorable results. 

All users are free, of course, to test (and debug) this software as 
desired. 


372 BYTE LISTINGS SUPPLEMENT 








This program was developed under the DeSmet C compiler, and utilizes 
DeSmet’s vastly useful in-line assembly language capability. 
Compiling it on other compilers (such as Lattice) may require 
EXTENSIVE modification. 

2/14/86 

*/ 

#define MIDID 0xffa0 
#define MIDIS 0xffa2 
#define PIC0 0x20 
#define PIC1 0x21 
#define CSTAT 0xFFA7 
#define COUNTER1 0xFFA4 
#define C0UNTER2 0xFFA5 

^define Tsize 25600 /* track size in bytes (24K) */ 

#define Tk 25 /* track size in K */ 

#deflne seg_per_trk 1600 /* track size in paragraphs */ 

/* the following structures hold data for each buffer */ 

char prog_Jd[]={"MIDInterface 1.11 (c) 1985, 1986 Jay Kubicky"\; 

struct rec { /* 63 bytes long 63*16=1008 bytes total */ 

char chan; 
unsigned ssize; 
char name[40]; 

char transpose; /* transpose amount */ 
char extra[19]; /* for later use */ 

\ parts[16]; 


char in_filt; 


/* This is the MIDI input filter mask: 
bit: message filtered out: 


0 

1 

2 

3 

4 

5 

6 


char 

char 

char 

char 

char 


on[4]= M 0N "; 
off£4j« M 0FF M 


yes. 
no[4] 


-"YES"; 

"NO 


/* 


*0N* */ 
’OFF' */ 


sin_line[80]; /* A 79 char, 

unsigned r_segment; 
char *ptr, *end; 
int fd; char f1 Iename[30]; 


Note ON 

Note OFF 

Program Change 

Channel Pres. (After-touch) 

Pitch Wheel 

Control Change 

Poly. Key pres. (After-touch) 


single line*/ 


int r_tempo; /* tempo val (bpm) */ 

unsigned tempo; /* real tempo val. */ 

char destbyte, stop; 

char clsb, cmsb, dsync, MIDIsync, audmet; 
char rbuff; /* receive buffer */ 

char beat, mbeat,abeat, s_t_b, m_t_b, a_t_b; /* beats & time bases */ 


char buffon[16]; 
unsigned pointers[16]; 
unsigned startp[16]; 
unsigned endp[l6l; 
unsigned segment[16]; 


/* true means given buff is active */ 

/* an array of pointers into present buffers */ 
/* an array of starts of present buffer */ 

/* pointers to end of songs */ 

/* array of segments of tracks */ 


int pfd; 
char printer; 


/* fd for printer */ 
/* printer enable */ 


extern unsigned _rax, _rbx, _rdx, _res, _rds; 





June 


char LAST.STAT; 
char C_0_F; 
char clk_type; 
char counter_dec; 
char vir_buff[1024]; 
char buff1[Tsizej; 


/* 0-lnternal, 1-external */ 


char buff2[Tslze 


/* track 0 - 3070 notes */ 

/* track 1 - 3070 notes */ 

/♦"firsttwo tracks eat up 50K */ 

/* last fourteen will take 350K combined */ 

/* total note storage- 

3200 notes per track 
51200 notes in al1!!! */ 

char *_showsp(),*_showss(),*_showds(); 
maln() 

unsigned a; 

char cIkvaI,seI,b; Int c; 

unsigned base_seg, cont_mem; 

/* the following code stores the DS at 0x4FA */ 

/* THIS IS VERY IMPORTANT!!!!I II! */ 

/* this allows the DS to be transffered to the RXINT function */ 
# asm 

MOV CX.DS ; store DS In CX 
PUSH DS ; save DS 

MOV AX,0 ; this will be new value for DS 
MOV DS,AX ; put 0 In DS 
MOV WORD [04FAH], CX ; store DS 
POP DS ; retrieve DS 


/* MIDInterface 1.11 16-track digital sequencer 

Data storage format: 


byte num: 

Note ON 

Note OFF 

Prog Chan 

Chan Pres 
(after-touch) 
Pitch Wheel 

Cntrl Chan 

Key Pres, 
(after-touch) 


End 


(MIDI ORIENTED COMMANDS) 


first 

second 

th 1 rd 

fourth 

+ H 

00VVVVVV 

LLLLLLLL 

MMMMMMMM 

Innnnnnn 

00VVVVVV 

LLLLLLLL 

MMMMMMMM 

0nnnnnnn 

01000000 

LLLLLLLL 

MMMMMMMM 

0ppppppp 

01000001 

LLLLLLLL 

MMMMMMMM 

0aaaaaaa 

10WWWWWW 

LLLLLLLL 

MMMMMMMM 

— 

11000000 

LLLLLLLL 

MMMMMMMM 

0nnnnnnn 

01Ivvvvv 

i 

LLLLLLLL 

MMMMMMMM 

0nnnnnnn 

(INTERNAL ORIENTED COMMANDS) 

11000001 j LLLLLLLL 

MMMMMMMM 

i tttttttt 

11111111 | 

i -- i 

1 “ 1 

i -- 


fifth 


0CCCCCCC 



WWW 

- 

top 6 bits of velocity (NOTE ON 


LLLLLLLL 

- 

LSB of elk 


MMMMMMMM 

- 

MSB of elk 


nnnnnnn 

- 

note for either NOTE ON or NOTE 


PPPPPPP 

- 

new program 


aaaaaaa 

- 

chan pressure (after-touch) 


WWWWWW 

- 

top six of bender 


nnnnnnn 

- 

control number 


ccccccc 

— 

control value 


tttttttt 

_ 

new tempo value (40-200) 

*/ 

c-0; 
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start: 


pr intf( 
pr intf( 
pr intf( 
pr intf( 
pr intf( 
pr Intf( 
pr intf( 
printf ( 
pr intf ( 
pr intf( 
pr intf( 
printfC 
pr intf( 
pr intf ( 
pr intf( 
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while(c<79) 

sin. -O—> 2 
sin_line[c]= 

in_f I 11**0xf ^ fm Zxr “*£ fl t* cut anything */ 

clk_type*8: 

counter.dec*! 

rbuff*255; 

segment[0]=j*;---- /* 1st two buffs in DS */ 

startp[0l*b- : =:jff1+Tsize-8; 

startp[1J=r. : - - uff2+Tsize-8; 

parts[0].ss ze—: ; per*s'* ].ssize=0; 

/* This is *‘* T~mz -• r :::* :~ section. 

This is *•: • : nzr ~ -do-aI Iocation scheme 

allowing <*-*'~e system memory (up to 640K). 

Memory s : : : soft ~t 3 ::«s of 25k (1600 paragraphs). 

All trcc«s r-* z"mczGmz sequential ly until you run out 
of syste- - -*c tracks are taken care of 

in the I . as * 21 •r-* :*:.ld always be room for these. 

*/ r 

• r:*: just after stack */ 

/* This is the segment boundary of 
the bottom of un-initia Iized mem */ 
-9 z safety */ 

cont_mer-=ge * _r _r-rr 

cont.mea ** • r aw late i of system para. */ 

/* Here’s • ♦- "x: a:r** uemory" */ 


base_seg«_s~: 
base.seg •* . 1 - 3 * 

++base_seg; 


_setme*(sepr«?-*—* Z1 MT~ 
c=2; 

for (a~bcs«_aw: 

sejNrt'rW 
str'tc'r- 
e-: " 

*> crii lK - 

pcrt*[c]_ 2 -i 


} 



tt c < 16; a+=seg_per_trk) j 


/* default time bases */ 


m_t_b»2; s_-_r* 

pr inter*0; 
scr.cIo(); 

prlntf("Do • 1 - ^ wm winter as an audio meternome?"); 
i f (toupper ;•*:*sr[J j— T] 

pr -•* ’ : >ter and hit any key"); 

getclsor 5 ^ ^ ^ 

I :• ccening printer ... aborting\n"); 

I 

beepp 
pr inters* 

i 



setdart(); 

intoff(); 

scr_cla(); 

11 



m 


/• t. 


off */ 


7 /; 'vvvvvvvvvvvvvvi>vvvvi>vvvin>i>vvv[\n ") 


7 ^I>-erixc« *.11 16 Track Digital Recorder V\n") 

wain Menu:\n"); 

5556566666\n") ; 

.Erase a track\n"); 

2- ...Record to a track\n M ); 

u.Ploy from a track\n"); 

* --Track Information\n"); 

i .Save a track\n"j); 

!rtflH n trnrk\n" 


i --LUUU VJ U \I1 J t 

7— ..Set MIDI modes\n"); 

.Edit input f i I ter\n") ; 

f ...Quit\n"); 
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}une 


scr.rowcoI(24,0); 

printf(" Copyright (C) 1985, 1986 by Jay Kubicky"); 

scr.rowcol(18,0); 

printf(" Enter Selection;"); 

sel-getchar(); 
switch (sel) j 
case * 1 *; 

erbuff(); 
break; 
case '2’: 

recbuff(); 
break; 
case *3*: 

pbuffs(); 
break; 

* 4 ’ : 

dbuffs(); 
break; 
case *5’: 

strack(); 
break; 

’6*: 

I track(); 
break; 
case *7’: 

mmode(); 
break; 
case *8*: 

ed.in.filt(); 
break; 
case *0’: 

scr.cI a(); 
b=0; 

for(a»0; a<16; ++a) } 

if(parts[a].ssize) { 

b»1; /* toggle high */ 

printf(" Data still left in track %d\n",a); 

if(!b) I 

c lose(pfd); 
ex 11(0); 


case 


case 


printf("StiI I want to exit? "); 
if(toupper(getchar()) ■■ *Y # ) 
cIose(pfd); 
exit(0); 




defauIt: 


/* 


goto start; 


oto start; 


*/ 

dbuffs() 
\ 


DBUFFS 

This is the general buffer display routine. 

It displays all pertinent data for all avaiable buffers. 


char a,b; unsigned tn,nf,nu; 
scr.cIa(); 

printff" Track Assignment Screen:\n"V, 

p r in t f( " vvvvvvvvvvvvvvvvvvvvvvvv\n " ); 

printf("Track Num; Transmit Chan: Notes Used; Transpose: EnabeIed:\n"); 

printf("%s\n",sin.line); 
for(a=0; a<16; ++a) } 

if(segment[a]) { 

tn=(endp[a]-startp[a])/8; 
nf=tn-(parts[a].ssize/8); 
nu=tn-nf; 

b*parts[a].transpose; 

print f("%d\t\t%d\t\t%d\t\t%d\t\t%s\n",a,parts[a].chan,nu, 
b < 128 ? b : -256+b, buffonfa] 

\ 

e I se 
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pr i nt f ( "—\t\t—\t\t—\t\t—\t\t—\n " ); 

print f("%s\n",sin_line); 
ttag: scr_rowcoI(21,0); 

printf("Change one trans. channel (1), change all (2), transpose(3), 

enable status (4)\n"); 

printf("or (0) to quit/continue: "); 

a=getchar(); 

scr_rowcol(22,17); 

scr_cls(); /* clear rest of current line */ 
switch(a) { 

case *0*; 

return; 
break; 
case *1': 

printf(" Enter track number:"); 
b*getint(); 
scr_rowcol(23,0); 

printf( M Enter new transmit channel:"); 
parts[b].chan=getint(); 
break; 
case *2': 

printf(" Enter new transmit channel for all tracks:"); 
a»getint(); 
for(b*0; b<16; ++b) 

parts[b].chan-a; 

break; 
case *3’: 

printf(" Enter track number:"); 
b»getint(); 
scr_rowcoI(23,0); 

printf(" Enter new transpose amount:"); 
parts[b].transpose-getint(); 
break; 
case *4*: 

printf(" Enter track number:"); 
b«getint(); 

if(parts[b].ssize kk b !- rbuff) 

buffon[b]« buffon[b] ? 0 : 1; 

break; 

defau11: 

goto ttag; 

goto s_; 


/* ERBUFF 

This funct. erase a buffer (set the size to 0) 

*/ 

erbuff() 

scr_cIa(); 
char b; 

printff" Erase a Track\n"); 

printf("%s\n",sin_lIne); 
printf("\nWhich buffer? "); 
b«getT nt(); 

printf("Are you sure you want to erase buffer %d?",b); 
1f(toupper(getchar()) !■ *Y’) 
return; 

parts[b].ssize=0; 
buffon[b]«0; 


/* PBUFFS 

This Is the top-level play-buffer routine. 

*/ 

pbuffs() 

int m; 
copyptrs(); 


scr_cla(); 

printff" Play Track Mode\n"); 

printff"Xs\n\n\n",sin_line); 
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printf(" Hit any key to continue\n"); 

getchar(); 

dbuffs(); 

scr_cla(); 

printff" Play Track Mode\n"); 

prIntf("%s\n\n\n",sin_lIne); 

get_options(); 

prIntf( M \nHit space bar to continue, any other key to quit\n M ); 
If(getchar()!«32) 
return; 
setrec(); 
destbyte=»0xf f; 
playQ; 

intoff(); 

_outb(5,MIDIS); /* send off to drum mach. */ 

_outb(104,MIDIS); 

_outb(0xfc.MIDID); /* MIDI seq off */ 

for(m«0; m<16; ++m) j 
i f(partsfmj.ssize) 

buffon[ml*1; 


RECBUFF: 

This Is the track record routine. 

All it really does is set up & enable the interrupt routine - 
Rxlnt 

*/ 

recbuff() 

char b; Int m; 

copyptrs(); 

scr_cla(); 

prlntf(" Record a Track\n"); 

printf("%s\n\n",sin_line); 
pr intf (" Which buffer: 1 '); 

b*getint(); 

if(parts[b].ssize) j 

printf("That buffer already has music, still want to record (Y/N)?"); 
If(toupper(getchar()) !« *Y') 
return; 

I f (isegment[b]) \ 

printf("Sorry, that track is not available to record in.\n"); 
hak(); 
return; 

rbuff*b; 

parts[bl.ssize=0; 

dbuffs(); /* display buff enable board w/ option to change */ 
scr_cla(); 

get.options(); 

printf("\nHit any key to begin recording\n"); 

getcharO; 

scr_cI aO J 

printf("Hit any key to stop recording\n"); 

setrec(); 
play(); 

_poke(255,ptr,segment[rbuff]); /* EOS (end-of-song) */ 

parts[b].ssize=ptr-startp[rbuff]; 

printf("\nSong is %d notes long\n",parts[b].ssize / 8); 
rbuff-255; /* no more record buffer */ 

pointers[b]=startp[b]; /* copy start pointer */ 

buffon[b]=1; /* enable present buffer */ 

_outb(5,MIDIS); /* send off to drum mach. */ 

_outb(104,MIDIS); 

_outb(0xfc,MIDID); /* MIDI seq off */ 
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rbuff»0xff; 
hok(); 


J une 


} 


/* SETREC 

This sets up c 

*/ 

setrec() 

int a; 


r~ fzr Play & Record. 


stop»0; 
destbyte-8; 
setint(); 
ptr«startp[r:. * - ' 
end*endp[rfc.•• 
r_segment-sef * 
end«endp[rfc_ * * ' - 
C_O_F«0x98; 
beat-abeat*-:*: * • 

i f(dsync) 

.OL*: : tfH : • !?*: start to drums */ 

^ _ol:: =— r- e : : 

if(MIDIsync) _ 

_c.*r : : Ml: Zfi /* start ext seq */ 

pointers= s•: z* 
pointers[*-: -“ * 

setcounte' » 8,255,255); 


copyptrs() /* cc:- f: :.*'ers into pointer areas */ 

char a; 

for(a-0; c< * 5 —r 

po s]; 


/* LTRACK 


*/ 

I track() 

\ 


Load a trock 


char tr; 
scr_cla(): 

printff" Load a Track\n M ); 

printf("%s\n*.• -t 

dir("????????• • — 

scr.rowcol (2,e); 

printf(" Locc ** c; *: • ); 

tr«getint(); 

If(ports[tr].ssize) f 

print';'T:*: c n that track ... abortingAn"); 

getchor(); rttirn; j 

printf(" Load **om r* r file:"); 
scant("%s",fi e-c** 
if((fd-open(filenaae 2)) — -1) | 

prIntf("Can*t open %s ... abort1ng\n",fiIename); 

getcharQ; 

return; 

i f(read(fd,parts[tr].S3) «» -1) J 

printf("Error encountered during reading.\n"); 

getchar(); 

return; 

Jf(seg_read(fd,tr,parts[tr].ssize+1) — -1) j 

printf("Error encountered while reading.\n"); 
getchar(); return; } 

c lose(fd); 

printf("Total bytes loaded from disk:%d\n",parts[tr].ssize+63); 
buffonftr]«1; 
getchar(); 
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/* STRACK 

Save a track to disk. 

*/ 

strack() /* save a track */ 
char tr; 

scr_cla(): 

printff" Save a Track\n"); 

printf("%s\n",sin.line); 

dlr("????????", ,, ??? M ); 

scr.rowco1(2,0); 

prlntf(" Save which track:"); 

tr«getint(); 

If(iparts[tr].ssize) { 

prIntf("Nothing In that track ... abortlng.\n"); 
getchar(); return; } 
prlntf(" Save to what file:"); 
scanf("%s",filename); 
lf((fd»creat(fiIename)) ■* -1) j 

printf("Can't creat %s ... abortlng\n",fiIename); 

getchar(); 

return; 

If(wrlte(fd,parts[tr],63) — -1)^ j 

prIntf("Error encountered during wr1tlng.\n"); 

getchar(); 

goto .end; 

If(seg.write(fd,tr,parts[tr].ssize+1) ■■^-1) { 

printf("Error encountered while writing.\n"); 
aetchar(); goto .end; ( 

close(fd); 

pr1ntf("TotaI bytes written to disk:%d\n",parts[tr].ssize+63); 

hak(); 

return; 

.end: 

close(fd); 


/* SEG.READ, SEG.WRITE 

These functions carry out intra-segmentary disk I/O functions. 

*/ 

seg_reod(fd,tr.size) 

int fd, tr; unsigned size; 

unsigned a; 

a=startp[tr]; /* this won't be 0 for tr. 0 k 1 : it's a pointer */ 

1f(s1ze > 1024) j 

size+*a; /* make size look like a pointer */ 

for(;a < (size-1024); a+«1024) { 

if(read(fd,vir.buff,1024) == -1) 
return(-1); 

_lmove(1024,vir.buff,_showds(),a,segment[tr]); 


e I se 

size+«a; 


1 f(!(size-a)) 

return(1); 

1f(read(fd,vir.buff,size-a) *» -1) 
return(-1); 

.Imovefsize-a,vir.buff,_showds(),a,segment[tr]); 
return(l); 


seg.write(fd.tr.size) 
int fd, tr; unsigned size; 

unsigned a; 

a=startp[tr]; /* this won't always be 0 because of tracks 0 & 1 */ 

if(size > 1024) } 

size+*a; /* make size look like a pointer */ 

for(;a < (size-1024); a+«1024) \ 
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}une 


_lmove(1024,a,segment[tr],virebuff,_showds()); 
if (write(fd,vir_buff,1024) *= -1) 
return(-1); 


\ 

e I se 


size+»a; 




If(!(size-a)) /* Is the buff length 0 || have we written all data? */ 

return(1); 

_lmove(sIze-a,a,segment[tr],vlrebuff,_showds()); 

If(write(fd,vlr_buff,size-a) ** -1) 
return(-1); 
return(1); 


/* Play() - 

This function plays through the 16 tracks until track 0 ends 
or a key is struck. 


*/ 

ploy() 

\ 


sp: 


Int playing; 
char a,ch,b; 
unsigned n; 
scr_rowco1(2,0); 
pr intf("Tempo: 


%d",r_tempo); 


for (a=0; a<15; ++a) { 

if(buffon[a] && a!*rbuff) 
if(playfrom(a)) \ 
if (a) 


I 


/* Track or song end */ 

/* If not track 0 */ 
buffon[a]=0; /* turn off buff */ 


e l se 




\ 


return; 


If(dsync) 

btQ; 
if(MIDIsync) 

bt2(); 
If(oudmet) 

bt3(); 


If(!(ch-scr_csts())) 
goto sp; 


else { 


switch(ch) 


case - 


defauIt: 


++r_tempo; 
break; 

». 

—r_tempo; 
break; 

return; 


scr_rowcoI(2,10); 
printf("%d",r_tempo); 
tempo«2000000/((r_tempo*48)/60); 
set_cnt_1(tempo,tempo » 8); 

i 

goto sp; 

p I ayfrom(a) 
char a; 

char *p,d,*p1; 

p«virebuff; 

_l move(8,pointers[a].segment[a],v!r_buff,_showds()); 

if(*p«»0 xff) /* check for EOS */ 
return(l); 
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readclk(); 

p1*p+2; 

if(*p1 > cmsb) 

goto pnow; 

If(*p1 < cmsb) 

return(0); 
lf(*(p+1) < clsb) 
return(0); 

pnow: /* now we know that it's time to play [notes]... */ 

d«*p Sc 0xc0; 
switch(d) j 

case 00: /* note on or off */ 

pnt(p,parts[a].chan.parts[a].transpose); 

pointers[o]+-4; 

break; 

case 0x40: /* prog chan / chan pres. / key pres. */ 

pchan(p,parts[a].chan); 
pointers[a]+=4; 
break; 

case 0x80: /* pitch bender */ 

w_f_e(); /* let FIFO empty */ 

_outbf0xE0+parts[a].chan.MIDID); /* send P. B. code */ 
w_f_e(); /* l«t FIFO empty */ 

_outb(0,MIDID); /* we didn’t store LSB */ 

w_f_e(); 

_outb(*p « 1.MIDID); /* send MSB */ 

pointers[a]+«3; 

break; 

case 0xC0: /* cntrl chan | temp chan */ 

cchan(p,parts[a].chan); 

If(!(*p&1)); /* make up for control change */ 
++pointers[a]; 
pointers[a]+=4; 
break; 

} 

return(0); 


pnt(p,tc,trans) 
char *p,tc,trans; 

# asm 

MOV SI.WORD [BP+41 
MOV AL,BYTE [SI+3J 
AND AL,128 
JZ znoff 

MOV AL.BYTE [BP+6] 
ADD AL.090H 

zcheat1: 

MOV DX.0FFA0H 
CALL w_f_e_ 

OUT DX.AL 

MOV AL,BYTE [SI+3] 
ADD AL,BYTE [BP+8] 
AND AL.07FH 
CALL w_f_e_ 

OUT DX.AL 
MOV AL.BYTE [SI] 
SHL AL,1 
CALL w_f_e_ 

OUT DX.AL 
JMP zalI done 

znoff: 

MOV AL,BYTE [BP+6] 
ADD AL.080H 
JMP zcheat1 

zaI I done: 


get p 

get *(p+3) 
strip off top bit 
play a note off 
get tchan 

add a basic note on 

here’s where we’ll cheat on a Note OFF 

MIDI Data port 

wait for DART FIFO to empty 

send byte 

get note to turn on 

add transpose vaI. 

strip off top bit 

wait for DART FIFO to empty 

send out note 

get velocity 

shift up Into range 

wait for DART FIFO to empty out 

send velocity 

finished 

send Note OFF command 
get transmit channel 
add basic Note OFF 
let’s take a short cut 

a I I done 


{ 

pchan(p.tc) /* Program change, channel pressure, or after-touch */ 
char *p,tc; 
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# asm 


zpchan: 


zchanp: 


zcheat2: 


asm 


ztchan: 


# 

/* 

# asm 


MOV DX.0FFA0H 

port 

MOV SI,WORD [BP-*’ 
MOV AL,BYTE [SI] 

5** P 

: get I.D. byte 

CMP AL.040H 

. I for Prog change 

JZ zpchan 

: - :-if Prog change 

CMP AL,041H 

I : for Chan pressure, after-touch 

JZ zchanp 

MOV AL,BYTE [B^-t* 

• se -oly. key press, (after-touch) 

:•* t'cnsmit chan 

ADD AL,0A0H 

key pressure 

CALL w_f_e_ 

OUT DX.AL 

s f: 'st byte 

MOV AL,BYTE [S1+2* 

; S*t key f 

CALL w_f_e_ 

OUT DX,AL 

MOV AL,BYTE [SI] 

pressure 

AND AL.01FH 

st- *p off bottom 5 

SHL AL,1 

SHL AL,1 

:jp two bits 

CALL w_f_e_ 

OUT DX,AL 

JMP za11done2 

Z z done 

MOV AL,BYTE [BP+«] 

change 

;* * transmit channel 

ADD AL.0C0H 

::sc prog chan 

JMP zcheat2 

_ s e :sde from above routine 

MOV AL,BYTE [==-:’ 

:*r--el pressure 
get trcnsmit channel 

ADD AL.0D0H 

::: rcsic chan pres 

JMP zcheat2 

CALL w_f_e_ 

e-t'y point from zpchan 
; wcit for DART 

OUT DX.AL 

; eerd byte 

MOV AL.BYTE [SU3] 

; get new vel 

OUT DX.AL 

; seftd 

>2: 

; Flic 

,tc) 

»tc; 

MOV SI,WORD [BP+4] 
MOV AL.BYTE [SI] 

: get p 

; get I.D. byte 

AND AL,1 

; bit 0 

JNZ ztchan 

; teepo change 

MOV AL.0B0H 

; now we know It's a cntrl chan 
; cntrl chan 

ADD AL.BYTE [BP+6] 

; odd transmit channel 

MOV DX.0FFA0H 

; MIDID port 

CALL w_f_e_ 

; wait for DART to empty 

OUT DX.AL 

MOV AL.BYTE [SI+3] 

; get cntrl # 

CALL w_f_e_ 

; wait for DART FIFO to empty 

OUT DX.AL 

MOV AL.BYTE [SI+4] 

; get cntrl val 

CALL w_f_e_ 

OUT DX.AL 

JMP _fine2 

; done 

MOV AL,extsync_ 

OR AL,AL 

; tempo change 

; set flags 

JNZ _fine2 

; If extsync mode, then this has no purpose 

tempo(*(p+3)+30); 

*/ 
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}une 


_fIne2: 


? 


w_f.e() /* this function 

# asm 

PUSH DX 
PUSH AX 
MOV DX,0FFA2H 
try_again: 

IN AL,DX 
AND AL,4 
JZ try_again 
POP AX 
POP DX 

t 

/* 

BT, BT2, BT3 


"sleeps" until the FIFO In the DART 

; DART status register 

; Tx buff empty? 

; no? 


*/ 

bto 


\ 


These are the meternome counting routines. 


readclk(); 

I f (beat«c I sb) | 

_outb(5,MIDIS+1); /* send sync high */ 

_outb(128.MIDIS+1); 

_outb(5.MIDIS+1); /* send sync low */ 

_outb(0,MIDIS+1); 
beat-*s_t_b; 


is empty */ 


bt2() 

readclk(); 
lf(mbeat«*cIsb) j 

_outb(0xf8,MIDID); /* MIDI timing elk */ 

mbeat-=m_t_b; 


bt3() 

readclk(); 

I f(abeat==cIsb) \ 

I f(printer) 

beepp(); 
abeat-=a_t__b; 


beepp() 

_rax=0x0500; 

_rdx«7; 

_doint(0x21); 

/* SETINT 

This routine sets up the interrupt. 

*/ 

setInt() 


Int rxintQ.a; 

int seg_num, (*fun_add)(); 

fun_add = rxint; 
seg_num*_showcs(); 

_pokeffun_add & 0xff,0x28,0); _pokeffun_add » 8,0x29,0); 
_poke(seg_num & 0 xff,0 x2a,0 ); _poke(seg_num » 8,0x2b,0); 
setdart(); 
setpic(); 
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setdort() 

_outb(24,MIDIS); 
_outb(1.MIDIS) 
_outb(3,MIDIs) 
_outb(4,MIDIS) 
_outb(5,MIDIS) 

setpic() 

{ 

char a; 
a=_inb(PIC1); 

If(a&4) 

a-*4; 

_outb(o,PICl); 

\ 


/* reset channel A */ 
_outb(24,MIDIS); /* int on 

_outb(193,MIDIS); 

_outb(196,MIDIS); 
_outb(104,MIDIS); 


/* read interrupt mask */ 

/* if DART is masked off */ 


all Rx + Ext Stat */ 


/* re-enable ints */ 


setcounter(11,m1,12,m2) 
char II,ml,12,m2; 

i 

char e,d; 

— outb(0x34,CSTAT); /* counter 1=mode 2 - read/load both */ 

e=d; d=e; 

_outb(0x70,CSTAT); /* counter 2= mode 0 - read/load both */ 
e«d; d=e; 

_outb(I2.C0UNTER2); /* set LSB of counter 2 */ 

e=d; d*e; 

_outb(m2,C0UNTER2); /* set MSB of counter 2 */ 

e=d; d*e; 

_outb(11,COUNTER1); /* set LSB of counter 1 */ 

e«d; d=e; 

_outb(m1,COUNTER1); /* set MSB of counter 1 */ 

readclk(); 

whiIe(cmsb1=255 kk clsb!«255) 
readcIk(); 

return; 

set.cnt.1(11,m1) 
char II,ml; 

_outb(11,COUNTER1); /* set LSB of counter 1 */ 

_outb(m1.COUNTERI); /* set MSB of counter 1 */ 

I 


intoff() 

outb(01.MIDIS); /* 

_outb(00,MIDIS); /* 

inton() 

_outb(01,MIDIS); /* 

- outb(24,MIDIS); /* 

readclkQ 

I 

# asm 


turn off my interrupt */ 
(at the DART) */ 


turn on my interrupt */ 
(at the DART) */ 


MOV AL,64 
MOV DX.0FFA7H 

CLI ; an interrupt right now from Rxint would be bad 

OUT DX.AL 

NOP 

NOP 

NOP 

SUB DX,2 
IN AL,DX 
MOV cIsb_,AL 


NOP 

NOP 

NOP 

IN AL.DX 
MOV cmsb_,AL 
STI 


Ints back on 


f 
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scr_cla() /* clear screen Sc pstn cursor at top */ 

scr_clr(); 
scr.rowco1(0,0); 


/* 

*/ 

mmode() 
st: 

ss: 


skip: 


MMODE 

This Is a no—frills routine for setting up various 
MIDI system modes 


char a,mo,v; 


scr_cI a(); 

prlntff" MIDI mode ass Ignments:\n"); 

pr intf ("%s\n'\sin.J Ine); 


putchar(*\n*); 
prIntf(" 1 

printf(" 2 

p r I n t f (" 3 

pr Intf (" 4 

prIntf(" 5 

pr Intf ('* 6 

printf(" 7 

prIntfi " 0 

printf("Enter new 
mo»getInt(); 
lf (!mo) 


lf(mo>7) 


return; 


Omn i 
Omn i 
Omn i 
Omn I 


ON 

OFF 

ON 

OFF 


■) 


/ Poly\n 
/ Poly\n 
/ Mono\n") 
/ Mono\n"; 
- Program change\n"); 


Al I notes 

- AlI notes 

- Ex It\n"); 
mode: '•); 


off (all channeIs)\n"); 
off (one channeI)\n"); 


goto st; 

1f(mo««6) 

goto skip; 

prIntf("Send over which channel:"); 
a*getInt(); If(a > 15) 

goto ss; 

printf("\nChannel %d:\n",a); 


swltch(mo) { 

case 1: 

prlntf(" Poly / Omni on\n"); 

P°ly(a); 
o_on(a); 
break; 

case 2: 

printf(" Poly / Omni off\n"); 

poly(a); 

omni_off(a); 

break; 

case 3: 

printf(" Mono / Omni on\n"); 
monofa); 
o.on(a); 
break; 

case 4: 

prlntf(" Mono / Omni off\n"); 
mono(a); 
omni_off(a); 
break; 

case 5: 

printff" Program change\n"); 
printf(" Enter new program: "); 
v»getInt(); 

_outb(192+a,MIDID); 

_outb(v,MIDID); 
break; 

case 6: 

for(a=0; a<16; ++a) j 

_outb(0xb0+a,MIDID); 

_outb(123.MIDID); 
w_f_e(); 

_outb(0,MIDID); 

i 

printf(" All notes off - all channeIs\n"); 
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getchar(); 
break; 

case 7: 

outb(0xb0+a,MIDID); 
_outb(123,MIDID); 
w-f-e ); 

__outb(0,MIDID); 

printf(" All notes off\n"); 

getchar(); 

break; 

i 

goto st; 

i 


o_on(ch) 
char ch; 

outb(176+ch,MIDID); 
Ioutb(125,MIDID); 

w_f_e(); 

_outb(0,MIDID); 
getchar(); 

\ 

omni_of f(ch) 
char ch; 

outb(176+ch,MIDI0); 
_outb(124,MIDID); 

_outb(0,MIDID); 
getchar(); 

\ 

poly(ch) 
char ch; 

outb(176+ch,MIDID); 
_outb(127.MIDID); 

w_f_e(): 

_outb(0,MIDID); 

getchar(); 

\ 


mono(ch) 
char ch; 

{ 

char v* 

prIntf("How many channels? (0 - # In receiver, or other) "); 
v-getint(); 

outb(176+ch,MIDID); 

_outb(126,MIDID); 

wj_e ); 

_outb(v.MIDID); 
getchorQ; 

\ 

get_av_mem() /* returns total system RAM - In K */ 

_doint(0x012); 
return(_rox); 

\ 


char *_showss() 

§ asm 

MOV AX.SS 

f 

hak() /* display "hit any key to continue" & wait */ 
puts("\n\n"); 

scr_cls(); „. 

p U t 8 (» Hit any key to continue. ); 


(continued) 
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whlle(!scr_csts()); 


|etInt() /* error check an input line k return int */ 

char lnln[20],*b,flag; 

stg: 

.gets(inln,20); 

If(strlen(inln)) j 

for(b»inIn;*b!■*\0';++b) { 

If(11sdig1t (*b) kk *b !- •-’) j 
putchar(7); 
goto stg; 


^ return(atoi(inln)); 

e I se 

putchar(7); 
goto stg; 


/* ED.IN.FILT 

Thi8 routine allows the user to edit the input filter 

*/ 

ed.in.fi 11() 

int n; 

scr_cla(); 

scr.rowcol(0,26); 

pr Intf("Edit Input Filter\n"); 

pr intf("%s\n\n",sin.line); 

st.fi It: 



goto re.try; 

if o*o 

return; 

n*1 « (n-1); /* make n into bit to complement */ 

in.filt - in.filt & n ? in.filt-n : in.filt+n; 
goto st.fi It; 


& 1) ? yes : 
& 2) ? yes : 
& 4) ? yes : 
& 8) ? yes : 
& 16) ? yes 
k 32) ? yes 
k 64) ? yes 




let.options() /* enter various user options */ 


em; pr1ntf("Enter metrenome speed:"); 
r_tempo«getInt(); 
if(r.tempo<40 || r.tempo>200) 
goto em; 

tempo-2000000/((r_tempo*48)/60); 
printf("Audio Sync (Y/N):"); 
audmet-ftoupper(getchar())««*Y*) ? 1:0; 

putchar(*\n*); 

prIntff"Drum Sync (Y/N):"); 
d8ync«(toupper(getchar())■*'Y*) ? 1:0; 
putchar(*\n *); 
prIntf("MIDI Sync (Y/N):"); 
MIDIsync*(toupper (getchar O)**^* ) ? 1:0; 


no) 
no) 
no) 
no) 
: no 
: no 
: no 
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/* dlr(fname.ext) 

char *fname,*ext; 

This function shows a directory of the currently logged directory 
and disk and print it on the screen in "five-across" format. 

*/ 

di r(fname.ext) /* function to show directory of currently logged disk k dir */ 
char *fname,*ext; /* pointers to filename k extension */ 

i 


struct fcb { 

char drive.num; 
char fiIename[8]; 
char extension[3]; 

char rest[25]; /* the rest of the fcb */ 

\ fcb; 

struct fcb fcb2; 
unsigned dta.add, dta.seg; 
char f i Iename[21]; 
char flag=4; 
char cnt=80; 

fcb.drive_num«0; 

strcpy(filename," "); 

strncpy(fcb.fiIename,fname,8); 
strncpyffcb.extens ion,ext,3); 

.setmem(fcb.rest,25,0); 

.rax=0x2f00; /* get current DTA */ 

_dolnt(0x21); 
dta.add«_rbx; 

dta_seg*.res; /♦ this is the offset k segment of the current DTA */ 

_rdx*fcb; 

_rds=_showds(); 

_rax«0x1100; 

scr.rowco1(6,0); 

printf("%s\n".sin_I 1ne); 

scr.rowco1(7,0); 
scr.cls(); 
for(;;) } 

.do Int(0x21); 
if((.rax k 0xff)) 

break; /* last file has been listed */ 
.lmove(20,dta.add,dta_seg,fcb2,_showds()); 
strncpy(fiIename,fcb2.fiIename,8); 
f1 Ienamersl-*.*; 
fIlenametQJ-’X©*; 
strcat(fiIename,fcb2.extension); 
fI Iename[12]*’\0*; 
puts(fiIename); 
puts(" M ); 

If(If lag) 

fIag=5; 

if(!—cnt) { 

printf(" Hit any key to continue."); 

getchar(); 

scr.rowcoI(7,0); 

scr.cIs(); 

cnt«80; 

fIag=4; 

\ 

—flag; 

.rax«0x1200; 

i 
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rxint11 .0 
TEXT 

"A MIDI Project," by Jay Kubicky. 

June, page 199. Also download midMIl.c. 


0 RXINT: 

; version 1.1 

; 2/2/86 

• 

; This is the main receive interrupt. 

; It Is called when the DART receives data. 

; This version supports carry-over (running) status bytes 

; as well as a translate table. 


DSEG 

; These are C’s globals 


PUBLIC 

r.segment. 


PUBLIC 

Ptr. 


PUBLIC 

end. 


PUBLIC 

destbyte. 


PUBLIC 

c 1 sb_ 


PUBLIC 

cmsb. 


PUBLIC 

stop. 


PUBLIC 

LAST.STAT. 


PUBLIC 

C.O.F. 

; status carry-over flag 

PUBLIC 

c1k.type. 

; 0=internal, 1«external 

PUBLIC 

counter.dec. 


PUBLIC 

in.f1 It. 

; the MIDI input fi1 ter 
; bit: 


0 = Note on flit 

1 « Note off filt 

2 = Prog change filt 

3 * Channel after-touch 

4 - Pitch wheel 

5 * AM other controllers 

6 * Key after-touch 


CSEG ; ALL CODE 


PUBLIC rxint. 


rxint.: 

STI 

PUSH AX 
MOV AL.0B9H 
OUT 021H,AL 
PUSH BX 
PUSH DX 
PUSH ES 
PUSH DS 
MOV AX, 0 

MOV DS, AX 

MOV BX,WORD [04FAH] 
MOV DS, BX 
MOV AX,r.segment. 
MOV ES, AX 


; interrupts back on 
; shut off counter interrupt 


; this will be new value for the 
; DS so we can access the OLD DS 

put new DS in BX 
; put new DS in DS 

; set buffer segment 


s s t: 

MOV DX.0FFA2H 
MOV AL, 1 
OUT DX.AL 
IN AL.DX 
AND AL ,32 
JNZ finished 

_st: 

aval table 

IN AL.DX 
AND AL, 1 
JZ .Iret 


; midi stat 

; rd register 1 

; RD reg 1 
; Rx overrun error? 

; if so, than we're REALLY done! 

; jumped to by _lret if another char is 

; read status register 
; Rx char? 

; if not, return 
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Cl: 


C4: 


revelation! 
contzz: 


MOV 

DX.0FFA0H 

; MIDI data 


IN 

AL.DX 

; now let’s read it 


MOV 

DL ,AL 

; store in DL for later 

CMP 

AL ,0F8H 

; timing clock? 


JNZ 

Cl 

; if not, check for 

stop 

MOV 

DL,counter_dec 

get amount to decrement 

counter 

MOV 

DH, 0 

; we’ll do a word subtract 

MOV 

AL,c1sb_ 

; get Isb 


MOV 

AH,cmsb_ 

; get msb 


SUB 

AX,DX 

; dcr word 


MOV 

c1sb_,AL 

; store Isb 


MOV 

cmsb_,AH 

; store msb 


JMP 

_I ret 

; if is, all done 


CMP 

AL.0FCH 

; MIDI Stop? 


JNZ 

C4 

; if not, continue 


MOV 

BYTE stop.., 41 

; else, set stop byte 


JMP 

_! ret 

; and return 


AND 

AL.0F0H 

; strip off top 4 


CMP 

AL,0F0H 

; running status? 


JZ 

_1 ret 

; if so, we’re done 


MOV 

BYTE AL,destc•* 

get destbyte 


CMP 

AL.0FFH 

; shal1 we continue? 


JZ 

_I ret 

; if not, then we’re 

done 

MOV 

BL, AL 

; keep for later 


AND 

AL.0F0H 

; strip off top four 


JZ 

_newmsg 

; first byte of a new 

message - 


CMP 
JZ . 
CMP 
JZ . 
CMP 
JZ . 
CMP 
JZ . 
CMP 
JZ . 


AL.010H 
.nton 
AL.020H 
.nof f 
AL.070H 
.keypres 
AL.040H 
.bender 
AL.050H 
.cchan 


What 

; branch point from carry-over status 
; Note ON? 

; yes? 

; Note OFF? 

; yes? 

; Poly key pres? 

; Bender? 

; yes? 

; Control Change? 

: yes? 


CMP AL.060H 
JZ _cveI 
CMP AL.030H 
JZ _pchan 
JMP _iret 


; Channel Velocity? 

; For now, throw away channel velocity 
; Prog Change? 

: yes? 

; This would fall through for FILTed out 


; this routine processes the first byte of a given 

; message, ana c so decides if it Is an important message 


_newmsg: 

MOV AL.DL 
AND AL.080H 
MOV AL,DL 
MOV BYTE C_0_F_, 0 
JNZ contxx 

MOV BYTE AL, LAST STAT_ 
MOV BYTE C_O_F_,0FFH 
contxx: 

MOV BYTE destbyte_,0 


MOV CL,1n_fI 11_ 
AND AL,0F0H 
MOV LAST_STAT_,AL 
CMP AL.090H 
JZ _nnon 
CMP AL.080H 
JZ _nnoff 
CMP AL,0A0H 
JZ _nkeypres 
CMP AL,0E0H 
JZ _npwch 
CMP AL.0B0H 
JZ _ncchan 
CMP AL.0C0H 


it’s a new message 
; retrieve 


; no carry-over 

; check for MIDI carry-over stat. 

; get previous status byte 
; carry-over status 

; this is default in case code isn't 
; supported or is filtered out 
; this is input f 1 I ter 
; strip off channel info. 

; save new last stat 
; Note ON? 

; yes? 

; Note OFF? 

; yes? 

; Poly key press? 

; yes? 

; Pitch Wheel 
; yes? 

; Control Change? 

; yes? 

; Prog. Chan? 


codes 


[continued) 
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JZ _npchon 
CMP AL.0D0H 
JZ _nchanv 
JMP _I ret 
support 


; yes? 

; Channel Velocity? 

* yes? 

; otherwise, It must be a code we don’t 


_nnon: 

AND CL.1 

JZ _lret 

CALL .stlme 

MOV BYTE ES: [BX] , 0 

MOV BYTE destbyte.,011H 

JMP _cco 


first byte of a note on just came in 
; keep note-ons? 

; no, then al I done. 

; store present time 

; put 0 at *ptr - I.D. code for note on/off 
; note on in dest byte 
; check carry-over 


_nnoff: 

AND CL,2 

JZ _Iret 

CALL .stlme 

MOV BYTE ES: [BX] , 0 

MOV BYTE destbyte.,021H 


first byte of note off just came in 
; keep note-offs? 

; no, then a I I done 
; same as _nnon (above) 

; I.D. 

; note off in destbyte 


JMP .cco 

.ncchan: 

AND CL,32 
JZ _i ret 
CALL .stlme 
MOV BYTE ES:[BX],0C0H 
MOV BYTE destbyte.,051H 
JMP _cco 

.npchan: 

AND CL,4 
JZ _J ret 
CALL .stlme 
MOV BYTE ES:[BX],040H 
MOV BYTE destbyte.,031H 
JMP _cco 

_nchanv: 

AND CL,8 
JZ _Iret 
CALL _stIme 
MOV BYTE ES:[BX],041H 
MOV BYTE destbyte.,061H 
JMP .cco 

.nkeypres: 

AND CL,64 
JZ _iret 
CALL .stime 
MOV BYTE ES:[BX],060H 
MOV BYTE destbyte_,071H 
JMP .cco 

.npwch: 

AND CL, 16 
JZ .iret 
CALL .stime 
MOV BYTE ES:[BX],080H 
MOV BYTE destbyte.,041H 
JMP _cco 

_cco: ; check carry over flag 

MOV BYTE AL,C_0_F_ 

OR AL, AL 
JZ _i ret 

MOV BYTE AL.destbyte. 

MOV BL.AL 
AND AL.0F0H 
JMP contzz 


; check carry-over 

; first byte of control change 

; keep control changes? 
; no 

; I.D. 

; cchan in destbyte 

; check carry-over 

; 1st byte of program change 

; keep prog, changes? 


; I.D. 

; prog chan in destbyte 
; check carry-over 

; 1st byte of Channel pressure 

; keep channel pressure? 


; I.D. 

; chan ve I In dbyte 

; check carry-over 

1st byte of Poly, key pres. 

; keep poly, key pres? 


; I.D. 

; chan vel in dbyte 

; check carry-over 

; first byte of pitch wheel change 
; keep pitch wheel? 


; I.D. 

; pitch wheel in dbyte 
; check carry-over 


; get carry over flag 
; set flags 


; carry over 


; now for the routines that are called while a message is in 
; progress: 
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.nton: 

AND BL.1 

MOV WORD BX.ptr. 

JZ .ntonvel 
OR DL.080H 
ADD BX,3 

MOV BYTE ES: [BX] ,DL 
INC BYTE destbyte. 
JMP .iret 
.ntonveI: 

SHR DL, 1 

OR BYTE ES: [BX] ,DL 
MOV BYTE destbyte.,0 
ADD WORD ptr_,4 
JMP .iret 


; note on processing routine 
; BL still has destbyte in it 
; get pointer 

; must be a 2, so go and save velocity 

; set top bit of note 
; inr pointer to note 
; store it 

; inr for velocity, which will come in next 
; all done 

; must be a velocity byte 

; shift velocity byte one to the right 
; OR it in 

; next byte will be a newmsg 
; inr ptr 
; all done 


_nof f: 

AND BL, 1 

MOV WORD BX,ptr. 

JZ .ntoffvel 
ADD BX, 3 

MOV BYTE ES: [BX] ,DL 
INC BYTE destbyte. 
JMP .1 ret 
_ntoffveI: 

SHR DL, 1 

OR BYTE ES: [BX] ,DL 
MOV BYTE destbyte.,0 
ADD WORD ptr_,4 
JMP _i ret 


; note off processing routine 
; BL still has destbyte in it 

; get pointer into buff 
; if destbyte=2, then it must be a velocity 
; inr to where we’ll store the note 
; store note; top bit should already be 0 
; inr destbyte for velocity 
; all done 

; must be a velocity byte 
; shift DL logically right 1 

; OR It in 

; next byte will be a newmsg 

; now _ptr points to the next message spot 
; all done 


.pchan: 

MOV WORD BX,ptr. 

ADD BX, 3 

MOV BYTE ES; [BX] ,DL 
MOV BYTE destbyte.,0 
ADD WORD ptr.,4 
JMP .iret 


; program change (new program) 

; get pointer; no need to check byte number 

; because only two bytes are transmitted 

; this is where we’ll store the new prog. # 

; store data 
; reset to newmsg 

; inr to pstn, of next massage 

; all done 


.bender: 

AND BL, 1 
JZ .bmsb 

INC BYTE destbyte. 
JMP .iret 

.bmsb: 

SHR DL, 1 

MOV WORD BX,ptr. 

OR BYTE ES: [BX] ,DL 
ADD WORD ptr.,3 
MOV BYTE destbyte.,0 
JMP .iret 


.cchan: 

AND BL.1 

MOV WORD BX,ptr. 

JNZ .cnum 
ADD BX, 4 

MOV BYTE ES: [BX] ,DL 
MOV BYTE destbyte.,0 
ADD WORD ptr.,5 
JMP .iret 

.cnum: 

ADD BX,3 

MOV BYTE ES: [BX] ,DI- 
INC BYTE destbyte. 

JMP _1 ret 

_cveI: 

MOV WORD BX.ptr. 

MOV BYTE ES:[BX+3],DL 
ADD WORD ptr.,4 
MOV BYTE destbyte.,0 
JMP .Iret 


; store bender data 
; first data byte? 

; if not, than go and store the MSB 
; inr for next pass 
; all done 

; store MSB of bender 
; shift DL down 1 
; get ptr 

; OR in top 6 of MSB of bender 
; inr pointer to next message 

; next message wi I I newmsg 
; all done 

; control change 
; control #? 

; get ptr. 

; if input is control #, then save it 
; this is where we’ll store the control value 
; store control value 

; next byte wi I I newmsg 

; inr to next message location 

; all done 
; number 

; address of control number 
; store control number 

; next byte will be control value 
; all done 

; channel velocity 
; load BX w/pointer 
; store velocity 

; Inr to next message pstn. 

; next byte will be new msg 
; all done 

(continued) 
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_keypres: 

AND BL, 1 

MOV WORD BX,ptr_ 

JZ _storepres 

ADD BX,3 

MOV BYTE ES: [BX] ,DL 

INC BYTE destbyte_ 

JMP _I ret 
_storepres: 

SHR DL, 1 

SHR DL, 1 

OR ES:[BX],DL 

MOV BYTE destbyte_,0 

JMP _lret 

; poly, key pressure 
; amount? 

; store key pressure 

; this is where to store the note num. 

; store It 

; next byte will be va 1 . 

; store key pressure 

; shift DL right 2 (/4) 

; OR it in 

; next byte new message 
; all done 

_stime: 
resu1ts 

; routine to read the PIT and store the 

PUSH DX 

MOV WORD BX,ptr_ 

MOV AL,clk_type_ 

OR AL.AL 

JNZ ext_c1k 

MOV AL.64 

MOV DX.0FFA7H 

OUT DX.AL 

NOP 

NOP 

MOV DX.0FFA5H 

IN AL,DX 

MOV BYTE ES:[BX+1],AL 

; In the buffer 
; preserve data 
; get pointer 
; get elk type (0»int) 

; set flags 

; is clk_type=ext_clk?? 

; counter latching operation 
; counter stat 
; out to PIT 

; stal 1 for time 

; counter 2 
; read _clsb 
; store in buffer 

NOP 

NOP 

IN AL ,DX 

MOV BYTE ES:[BX+2], AL 

POP DX 

RET 

; read _cmsb 

; restore data 

ext_c1k: 

MOV DL,clsb_ 

MOV DH,cmsb_ 

MOV BYTE ES:[BX+11,DL 

MOV BYTE ES:[BX+2J,DH 

POP DX 

RET 

; timing clock from MIDI 

; get MSB & LSB 

; store MSB & LSB 
; restore DX 
; all done 

_eo i: 

PUSH AX 

MOV AL,020H 

OUT 020H,AL 

POP AX 

RET 

; send EOI to PIC 
; we'll be using this 
; EOI 
; EOI 

; restore AX 
; all done 

_i ret 1: 

CALL _eoi 

; execute EOI and then return 

finished: 

MOV BYTE stop_,0FFH 

JMP f 2 

; Rx overrun error 
; CRITICAL ERROR III 

_l ret: 

MOV DX,0FFA2H 

IN AL.DX 

AND AL.1 

; all done rout i ne 
; DART status reg 

; RxD? (THIS WILL HAVE TO BE CHANGED TO CHECK 

JNZ sst 
f 2: 

; FOR EXTERNAL STAT. ALSO) 

; if so, than go to top of routine 
; C equivalent: 

; if(end > ptr) 

; goto okay; 

; else 

MOV BX,ptr_ 

; MOV DX,end_ 

; CMP DX.BX 

; stop=1; 
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JG f3 

MOV BYTE stop_,1 ; Woaaaahl! Stop Everything!! - We're out of memory 

mov a I,0b8h 
out 021h,a I 
POP DS 
POP ES 
POP DX 
POP BX 

POP AX ; retrieve registers 

call _eoi 

IRET ; ALL DONE!!!!!!! 


macview.pas 
TEXT 

"Decoding MacPaint on the IBM PC" by Mark Anacker. 
June, page 131 


MACVIEW.PAS - Display MacPaint pictures on the IBM PC 
graphics adapter. 

Mark Anacker 09/24/85 


PROGRAM MACVIEW; 
(*$V-*) 


*) 


TYPE 

STRING255 « STRING[255]; 

SCANLINE - ARRAY [1..80] OF BYTE; (* hi-res screen is 80 bytes wide *) 

CONST 

SCANFLAG ; BOOLEAN - TRUE; 

ODDLINE : INTEGER = 0; 

EVENLINE : INTEGER = 0; 


FILNAM : STRING[64]; 

PNTFIL : FILE OF BYTE; 

ELEN ; BYTE; 

ELEM : STRING255; 

OUTPAT ; STRING255; 

LCNT : INTEGER; 

CNT ; INTEGER; 

XPOS,YPOS : INTEGER; 

STLINE.ENLINE : INTEGER; 

EVSCREEN : ARRAY [0..99,1..80] OF BYTE ABSOLUTE $B800:$0000; 

ODSCREEN : ARRAY [0..99.1..80] OF BYTE ABSOLUTE $B800:$2000; 

DOIT : BOOLEAN; 

SLPTR : ARRAY [0..719] OF ^SCANLINE; (* pointers to scan line buffers *) 

PROCEDURE HELPMSG; 

BEGIN 

WRITE('MACVIEW - View MacPaint images ... by Mark Anacker'); 
WRITELNf' 09/24/85'); WRITELN;; 

WRITELN('This program will let you view an entire MacPaint image.' 
WRITELNf'First, transfer the picture file from the Mac. Then,’); 
WRITELNi'run this program and give it the file name. You may use 
WRITELNC'the keypad keys 1-3 and 7-9 to scroll over the image.’ 
WRITELN('Press the space bar to exit back to DOS.'); 

WRITELN; 

WRITELN('You may specify the file name on the command line.’); 
WRITELN; 

WRITELNf'Remember, the aspect ratio is different. The pict.'e • 
WRITELN('be distorted somewhat in the vertical dIrection.•]: 
WRITELN; 

END; 


(continued) 
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PROCEDURE GETFILE; 

VAR CNT : INTEGER; 

INCH : CHAR; 

BEGIN 

ASSIGN(PNTFIL,FILNAM); 

(*$I-*) RESET(PNTFIL); (*$I+*) 

IF IORESULTO0 THEN 
BEGIN 

WRITELN(’** Error opening file - halting ***); HALT(1); 
END; 

SEEK(PNTFIL,512); (* skip brush patterns *) 

YPOS:-0; LCNT:«0; OUTPAT:-”; 

SCANFLAG:-TRUE; 

ODDLINE:-0; EVENLINE:«0; 

STLINE:-0; 

END; 


PROCEDURE OUTSCREEN; 

VAR CNT.CNT2 : INTEGER; 

BEGIN 

FOR CNT:-1 TO LENGTH(OUTPAT) DO 

OUTPAT[CNT];-CHR(NOT ORD(OUTPAT[CNT])); 
NEW(SLPTR[LCNTl); 

FILLCHAR(SLPTR[LCNT]*,80,CHR(0)); 

MOVE(OUTPAT[1],SLPTR[LCNT] * .72); 

END; 


(* display line *) 


(* invert bits to black *) 

(* on white like the Mac *) 

(* allocate a new buffer line*) 
(♦fill it to bIack *) 

(* and copy the decoded bits *) 


PROCEDURE PUTLINE; (* 

BEGIN 

OUTPAT:-OUTPAT+ELEM; (* 

IF LENGTH(0UTPAT)>«72 THEN (* 

BEGIN 

IF LENGTH(0UTPAT)>72 THEN (* 

OUTPAT;-COPY(OUTPAT.1,72); 
OUTSCREEN; (* 

LCNT:-LCNT+1; OUTPAT:-••; 


FILLCHAR(OUTPAT,75,CHR(0)); (* 
END; 

END; 


decide if we need to do line *) 

build scan line pattern *) 

If we have a full line, *) 

if too long, truncate *) 

put it in the buffer *) 

reset the string *) 


PROCEDURE REPBLOCK; (* 

VAR TMPBYTE ; BYTE; 

CNT : INTEGER; 

BEGIN 

ELEN:«(256-ELEN); (* 

READ(PNTFIL.TMPBYTE); ( * 

ELEM:-**; 

FOR CNT:«0 TO ELEN DO 

ELEM:-CONCAT(ELEM,CHR(TMPBYTE)); 
PUTLINE; (* 

END; 


block of repeating data *) 


get character count *) 
get character to repeat *) 


(* make string of chars. *) 
test for a complete scan line *) 


PROCEDURE MIXBLOCK; (* block of mixed, raw data *) 

VAR TMPBYTE : BYTE; 

CNT ; INTEGER; 

BEGIN 

ELEM:-'*; 

FOR CNT:-0 TO ELEN DO 
BEGIN 

READ(PNTFIL,TMPBYTE); (* get characters *) 

ELEM:-CONCAT(ELEM,CHR(TMPBYTE)); (* add to running pattern *) 

END; 

PUTLINE; (* test for complete scan line *) 

END; 


PROCEDURE LOADBUF; (* read data from file *) 

BEGIN 

GETFILE; (* open file *) 

WRITELN(* Loading picture into buffer ... Please wait a moment*); 
REPEAT 
BEGIN 

READ(PNTFIL,ELEN); (* get a byte *) 

IF ELEN>127 THEN (* if 8th bit set. *) 

REPBLOCK (* it * s a repeater, else *) 

ELSE 

MIXBLOCK; (* it*s mixed *) 
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END; 

UNTIL LCNT>*726; (* until all 720 lines are done *) 

CLOSE(PNTFIL); 

END; 


PROCEDURE SHOWBUF; (* display the buffer on screen *) 

VAR CNT : INTEGER; 

BEGIN 

EVENLINE:*0; OOC_ls£:*0 

FOR CNT:*STLINE DO (* show the current 200 scan lines *) 

BEGIN 

IF (CNT AND *'ol TrEN (* even line *) 

BEGIN 


MOVE (SL?~[] V EVSCREEN[EVENLINE, 1 ] . 80) ; 
EVENLINE :*EVESLlsE+1; 

END 

ELSE 

BEGIN (• odd line *) 

M0VE(SLP7R[CK7]~.OC$CREEN[ODDLINE.1],80); 
OOOLINE:-OODLI*C+1; 

END; 

END; 

END; 


(* even I ines *) 


(* odd Iines *) 


PROCEDURE MOVEIT; (* scroll the picture up and down *) 

CONST 

FKTABLE : STRING[6l * *OPCG-I*; (* cursor/numeric key *) 

FKEQUIV : STRING[6j * '123789*; (* conversion table *) 

VAR INCH : CHAR; 

CNT : INTEGER; 

BEGIN 

REPEAT 

G0T0XY(75,1); WRITE(STLINE:3); (* put top scan line in upper corner 

READ(KBD,INCH); (* get the key from the user *) 

IF (INCH*CHR(27)) AND KEYPRESSED THEN (* if a real cursor key, *) 
BEGIN 

READ(KBD,INCH); (* get the key code *) 

IF POS(INCH,FKTA3LE)>0 THEN (* and convert to it's number *) 
BEGIN 

CNT:-POS(INCH,FKTABLE); INCH:«FKEQUIV[CNT]; 

END; 

END; 

CASE INCH OF 

'8* : BEGIN (* move image UP *) 

IF STLINE<520 THEN 
BEGIN 

FOR CNT:*0 TO 98 DO 
BEGIN 

MOVE(EVSCREEN[CNT+1,11,EVSCREEN[CNT,11.72); 

MOVE(ODSCREEN[CNT+1,1],ODSCREEN[CNT,1J,72); 

END; 

FILLCHAR(EVSCREEN[99,11,72,CHR(0)); 

FILLCHAR(ODSCREEN[99.1],72.CHR(0)); 

STLINE:-STLINE+2; 

MOVE(SLPTR[STLINE+198l A ,EVSCREEN[99,11,72); 

MOVE ( SLPTR [ STL INE+199 j 4 *, ODSCREEN [99,1 J ,72) ; 

END; 

END; 

*2' : BEGIN (* move image DOWN *) 

IF STLINE>1 THEN 
BEGIN 

FOR CNT:*99 DOWNTO 1 DO 
BEGIN 

MOVE(EVSCREEN[CNT-1,11,EVSCREEN[CNT,11,72); 

MOVE(ODSCREEN[CNT-1,1J,ODSCREEN[CNT,11.72); 

END; 

FILLCHAR(EVSCREEN[0,11,72,CHR(0)); 

FILLCHAR(ODSCREEN[0.1J.72,CHR(0)); 

STLINE:*STLINE-2; 

MOVE(SLPTR[STLINE]*,EVSCREEN[0,1],72); 

MOVE(SLPTR[STLINE+1]*,ODSCREEN[0,11,72); 

END; 


END; 

'3' : BEGIN (* page image DOWN *) 

STLINE:"STLINE-100; 


*) 


{continued) 


BYTE LISTINGS SUPPLEMENT 397 






June 


IF STLINE<0 THEN STLINE:-0; 

SHOWBUF; 

END; 

*9* : BEGIN (* page Image UP *) 

STLINE:-STLINE+100; 

IF STLINE>520 THEN STLINE;-520; 

SHOWBUF; 

END; 

•7* : BEGIN (* go to TOP of image *) 

STLINE:«0; SHOWBUF; 

END; 

*1* : BEGIN (* go to BOTTOM of image *) 

STLINE:*514; SHOWBUF; 

END 

END; 

UNTIL INCH-* *; f* exit when SPACE bar is pressed *) 

END; (* moveit *) 


(* main section *) 


BEGIN 

TEXTC0L0R(7); 

IF PARAMCOUNT-0 THEN 
BEGIN 
HELPMSG; 

WRITE('MacPaint file name ; 
IF FILNAM-** THEN HALT(2); 
END 
ELSE 

FILNAM:-PARAMSTR(1); 

IF POS(*.*,FILNAM)-0 THEN 
FILNAM:«FILNAM+ *.MCP *; 

LOADBUF; 

HIRES; 

SHOWBUF; 

MOVEIT; 

CLRSCR; 

END. 


* set color to gray *) 

* If a blank command line, *) 


(* show message, prompt for file *) 
*); READLN(FILNAM); 

(* If none given, exit to DOS *) 


f* else get file name from cmd line *) 
f* if no extension was given, *) 
t* assume .MCP *) 

(* load the file *) 

switch to hl-res mode *) 

C* display the buffer *) 
move it up and down *) 

(* clear the screen when done *) 
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DISKS AND DOWNLOADS 


Ordering Disks of BYTE Usr sgs 

Listings that accompany BYTE anides are available 
in a variety of disk formats and on Cauzin Softstrip. 
Each disk package (which som et im es consists of 
more than one disk) contains an entire month s 
listings. If you want to order a is* package from a 
previous month, please call (603; 924-9281 to find 
out how many disks it includes. 1b order listings 
(for noncommercial use only), fill out this form and 
send a check or money order in the correct 
amount to: 

BYTE Listings 

One Phoenix Mill Lar.e 

Peterborough. NH 03-158 

All prices include postage Prograr listings can 
also be downloaded via BYTEnet Listings at (617) 
861-9764. 

BYTE issue: _ 

COMMON 5 W-INCH FORMATS 

All cost $8.95. $10.95 outside US A. Annual 
subscription is $69.95. $89.95 outside U.S.A. 

□ Apple II 514-inch DOS 3.3 

□ Apple II 514-inch ProDOS 

□ Hewlett-Packard 125 

□ IBM PC 

□ Kaypro 2 CP/M 

□ Texas Instruments Professional 

□ TRS-80 Model III 

□ TRS-80 Model 4 

□ Zenith Z-100 

COMMON 3'/2-INCH FORMATS 

All cost $9.95, $11.95 outside U.S.A. Annual 

subscription is $79.95, $99.95 outside U.S.A. 

□ Apple Macintosh 

□ Atari 520ST 

□ Commodore Amiga 

□ Data General/One 

□ Hewlett-Packard 150 

CP/M STANDARD 8-INCH FORMAT 

All cost $9.95, $11.95 outside U.S.A. Annual 

subscription is $79.95, $99.95 outside U.S.A. 

□ Single-sided single-density 

□ Double-sided double-density 


OTHER FORMATS 

Due to the diversity of requests and the custom 
work involved, there will be some delay in fulfilling 
these requests. All cost $9.95, $11.95 outside U.S.A. 
Annual subscription is $79.95, $99.95 outside 
U.S.A. 

Size □ 8-inch □ 514-inch □ 3'/5-inch 

Machine _ 

SEND TO: 

Name_ 

Street_ 

City_State or Province_ 

Postal Code_Country_ 

Check or money order enclosed for $_ 

Bulletin Boards in Canada 

Listed below are some computer bulletin boards 
that carry program listings from BYTE. Programs 
are for noncommercial use in connection with 
BYTE articles only. Some BBSs may charge an 
annual maintenance fee. and you must pay your 
own telephone charges. 

Western Canadian Distribution Center 3421 - ; -.- 
St.. Edmonton. Alberta T6L 3R5) will be supplying 
listings to its member bulletin board systems 

Edmonton. Alberta. (403) 454-6093 
Meadowlark, Alberta. (403) 435-6579 
Montreal. Quebec. PComm Sysie~s 1 514) 989-9450 
Prince George. British Columbia 16Tu, 562-9519 
Regina. Saskatchewan. (306) 5 5r-~585 
Canadian Remote Systems. Toronto 

Toronto. Ontario. Epson Club _ :-onto (EPCOT). 
(416) 635-9600 

Winnipeg, Manitoba. i204| - -1-" 529 

In addition, arrangements for BYTEnet Listings have 
been made with one or mote system operators in 
the following nations: Ausbafia Austria. Brazil. Den¬ 
mark. France Hc-g Kccg Indonesia Italy. lapan. 
Malaysia. The Netherlands. Kgeria. Norway. Saudi 
Arabia. Singapote Sweden. Switzerland. United 
Kingdom, and Ifest Germany. Contact us at (603) 
924-9281 for an iMcxlate fist ■ 
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EDITORIAL CALENDAR 


1987 

May — Desktop Publishing: An exploration of the hardware and software needed for desktop publishing, 
from page description languages to high-resolution printers and typesetting back ends. 

June — Computer-Aided Design: The anatomy of computer-aided design/drafting software, the graphics 
display devices needed for CAD. and the data structures used by CAD programs to export data to other 
applications. 

JULY — Local Area NETWORKS: The technology of linking personal computers together to share data 
files, programs, and peripheral devices. 

AUGUST — PROLOG: A look at logic programming with articles on tips and techniques and explorations of 
the tasks Prolog is best suited for. 

SEPTEMBER — PRINTER TECHNOLOGIES: An examination of the state of the art in printer technologies, 
including laser, liquid-crystal shutter, and ink-jet technologies. 

October — Heuristic Algorithms: Artificial intelligence techniques for giving computers the ability 
to learn from experience. 

November — High-Performance Workstations: A tour of the technology underlying the work¬ 
stations used by scientists and engineers in computer-aided engineering/design. 

December — Natural Language Processing: The technology of getting computers to under¬ 
stand the natural language of man. 


1988 

JANUARY Managing MEGABYTES: Looking at the ways computers store and retrieve data in situations 
where disk space is measured in gigabytes and memory is measured in megabytes. Also a look at the 
new applications that mega-memory and storage will permit. 

FEBRUARY — LISP: A BYTE reexamination of the original language of artificial intelligence research. 

March Floating-Point Processors: a look at the processors that speed the computation of 
mathematical operations in personal computers, including coprocessors and array processors. 

APRIL Memory Management The hardware and software issues in managing a personal computer s 
memory space. 

MAY CPU ARCHITECTURES: An exploration of the latest 32-bit microprocessors, including digital signal 
processors and programmable graphics processors. 
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Six great reasons to join EIX today 


• Over 140 microcomputer-related conferences: 

loin only those subjects that interest you and change 
selections at any time. Take pan when it's convenient 
for you. Share information opinions and ideas in 
focused discussions with other BIX users who share 
your interests. Easy commands and conference digests 
help you quickly locate important information. 

• Monthly conference specials: 

BIX specials connect you with invited experts in lead¬ 
ing-edge topics—CD-ROM. MIDI OS-9 and more 
They're all part of your BIX membership 

• M icrobytes daily: 

Get up-to-the-minute industry news and new prod -ct 
information by joining Microbytes Daily and Whafs 
New Hardware and Software. 

• Public domain software: 

Yours for the downloading, including programs from 
BYTE articles and a growing library of PD listings 

• Electronic mail: 

Exchange private messages with BYTE editors and 
authors and other BIX users. 



BIX User’s Manual and Subscriber Agreement 
as Soon as Wve Processed Your Registration. 
JOIN THE EXCITING WORLD' 

OF BIX TODAY! 


• Vendor support: 

A growing number of microcomputer manufacturers 
use BIX to answer your questions about the:: products 
and how to use them for peak performance. 


What BIX Costs. .How You Pay 


Join BIX Right Now: 

Set your computer's telecommunications program for 
full duplex. 8-bit characters, even parity. 1 stop bit OR 
7-bit characters, even parity. 1 stop usmg 300 O' :20C 
baud. 

Call your local tymnet number and respond as fcf cws 


ONE-TIME REGISTRATION FEE S25 


Hourly 

Charges: 

(Your Time 
of Access) 


Off-Peak 

6PM-7AM 

Weekdays Plus 
Weekends 
& Holidays 


Peak 

7AM-6PM 

Weekdays 


Tymnet Prompt You Enter 

Garble or "terminal identifier a 


login: 
password: 
mhis login: 

BIX Logo—Name: 


byteneti <CR> 
mgh <CR> 
bix <CR> 
new <CR> 


BIX $9 $12 

tymnet* * $2 $6 

TOTAL SI 1/hr. $ 18/hr.** 

• Continental U.S. BIX is accessible via Tymnet from throughout the US. at charges 
much less than regular long distance. Call the BIX helpline number listed below 
for the Tymnet number near you or Tymnet at 1-800-336-0149 
'* User is billed for time on system tie.. Vt Hr. Off-Peak wTymnet - S5.50cfwr^.| 

BIX and Tymnet charges billed by Visa or Mastercard only. 

BIX Helpline 

(8:30 AM-IL30 PM Eastern Weekdays) 

U.S. (except NH|-1-800-227-BYTE 
Elsewhere (603) 924-7681 


After you register on-line, you :e —ed:ately taken to 
the BIX learn conference ann : m r.a~ ,5 ng the system 
right away. 

Foreign Access: 

To access BIX from foreip) countries, you must have 
an account with your local Pose! 'Mephone & telegraph 
(PTT) company. From your PTT e nt er 310600157878. 
Then enter bix <CR> and new <CR> at the prompts 
Call or write us for PTT contact information 

BIX 

One Phoenix Mill Lane 
Peterborough NH 03458 
(603i 924-9281 









Announcing BYTE’s 
New Subscriber Benefits 


Y 

-Lou 


Program 


.our BYTE subscription brings 
you a complete diet of the latest in 
microcomputer technology every 
30 days. The kind of broad-based 
objective coverage you read in 
every issue. In addition , your 
subscription carries a wealth of 
other benefits. Check the check 
list: 

DISCOUNTS 

id 13 issues instead of 12 if you 
send payment with subscription 
order. 

ijf One-year subscription at $21 
(50% off cover price). 

id Two-year subscription at $38. 

Three-year subscription at $55. 

2 One-year GROUP subscription 
for ten or more at $17.50 each. 
(Call or write for details.) 

SERVICES 

BIX: BYTE’s Information 
Exchange puts you on-line 24 
hours a day with your peers 
via computer conferencing and 
electronic mail. All you need to 
sign up is a microcomputer, a 
modem, and telecomm 
software. 

jd Reader Service: For information 
on products advertised in 
BYTE, circle the numbers on 
the Reader Service card 
enclosed in each issue that 
correspond to the numbers for 
the advertisers you select. Drop 
it in the mail and we’ll get 
your inquiries to the advertisers. 

^ TIPS: BYTE’s Telephone 
Inquiry System is available to 





subscribers who need fast 
response. After obtaining your 
Subscriber I.D. Card, dial TIPS 
and enter your inquiries. You’ll 
save as much as ten days over 
the response to Reader Service 
cards. 

li Disks and Downloads: 

Listings of programs that 
accompany BYTE articles are 
now available free on the 
BYTEnet bulletin board, and 
on disk or in quarterly printed 
supplements. 

Si Microform: BYTE is available 
in microform from University 
Microfilm International in the 
U.S. and Europe. 

^ BYTE’s BOMB: BYTE’s 
Ongoing Monitor Box is your 
direct line to the editor’s desk. 
Each month, you can rate the 
articles via the Reader Service 
card. Your feedback helps us 


keep up to date on your 
information needs. 

Si Customer Service: If you have 
a problem with, or a question 
about, your subscription, you 
may phone us during regular 
business hours (Eastern time) 
at our toll-free number: 800- 
258-5485. You can also use 
Customer Service to obtain 
back issues and editorial indexes. 

BONUSES 

Jfcj Annual Separate Issues: In 
addition to BYTE’s 12 monthly 
issues, subscribers also receive 
our annual IBM PC issue free 
of charge, as well as any other 
annual issues BYTE may 
produce. 

2 BYTE Deck: Subscribers 
receive five BYTE postcard 
deck mailings each year—a 
direct response system for you 
to obtain information on 
advertised products through 
return mail. 

To be on the leading edge of 
microcomputer technology and 
receive all the aforementioned 
benefits, make a career decision 
today. Call toll-free weekdays, 
8:30am to 4:30pm Eastern time: 
800-258-5485. 

And. . . welcome to 
BYTE country! 
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